monadic-bang 0.2.2.2 → 0.2.2.3

raw patch · 17 files changed

+1776/−1757 lines, 17 filesdep +filepathdep ~basedep ~containersdep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: filepath

Dependency ranges changed: base, containers, ghc, ghc-boot

API changes (from Hackage documentation)

Files

• CHANGELOG.md +30/−26
• README.md +399/−399
• monadic-bang.cabal +132/−130
• src/MonadicBang.hs +13/−13
• src/MonadicBang/Internal.hs +472/−468
• src/MonadicBang/Internal/Effect/Offer.hs +35/−35
• src/MonadicBang/Internal/Effect/Uniques.hs +41/−41
• src/MonadicBang/Internal/Effect/Writer/Discard.hs +24/−24
• src/MonadicBang/Internal/Error.hs +49/−49
• src/MonadicBang/Internal/Options.hs +61/−61
• src/MonadicBang/Internal/Utils.hs +38/−38
• test/MonadicBang/Test.hs +51/−51
• test/MonadicBang/Test/ShouldFail.hs +64/−64
• test/MonadicBang/Test/ShouldPass.hs +153/−153
• test/MonadicBang/Test/Utils.hs +100/−100
• test/MonadicBang/Test/Utils/QualifiedDo.hs +13/−13
• test/MonadicBang/Test/Utils/RunGhcParser.hs +101/−92

@@ -1,26 +1,30 @@-# Revision history for monadic-bang
-
-## 0.2.2.1 -- 2024-05-20
-
-* Only run plugin on modules that contain bangs
-
-## 0.2.2.0 -- 2024-05-20
-
-* Added support for GHC 9.10
-
-## 0.2.1.0 -- 2023-10-16
-
-* Added support for GHC 9.8
-* Prefix internal modules with `Internal`
-
-## 0.1.1.0 -- 2023-07-10
-
-* Removed debug log message (thanks evincarofautumn!)
-* Minor documentation fixes
-* Added quotes to variables in error messages
-* Added test for `-XQualifiedDo`
-* Added support for GHC 9.6
-
-## 0.1.0.0 -- 2023-01-07
-
-* First version
+# Revision history for monadic-bang++## 0.2.2.3 -- 2026-02-04++* Added support for GHC 9.14++## 0.2.2.1 -- 2024-05-20++* Only run plugin on modules that contain bangs++## 0.2.2.0 -- 2024-05-20++* Added support for GHC 9.10++## 0.2.1.0 -- 2023-10-16++* Added support for GHC 9.8+* Prefix internal modules with `Internal`++## 0.1.1.0 -- 2023-07-10++* Removed debug log message (thanks evincarofautumn!)+* Minor documentation fixes+* Added quotes to variables in error messages+* Added test for `-XQualifiedDo`+* Added support for GHC 9.6++## 0.1.0.0 -- 2023-01-07++* First version

@@ -1,399 +1,399 @@-# Monadic Bang
-
-[![Run Tests](https://github.com/JakobBruenker/monadic-bang/actions/workflows/haskell.yml/badge.svg?branch=main&event=push)](https://github.com/JakobBruenker/monadic-bang/actions/workflows/haskell.yml)
-
-This is a GHC Parser plugin for GHC 9.4 and above, intended to make monadic code within `do`-blocks more concise and nicer to work with. Works with HLS.
-
-This is heavily inspired by [Idris's !-notation](https://idris2.readthedocs.io/en/latest/tutorial/interfaces.html#notation), but with some [important differences](#comparison-with-idriss--notation).
-
-## Contents
-
-1. [Motivating Examples](#motivating-examples)
-2. [Usage](#usage)
-3. [Cute Things](#cute-things)
-4. [Caveats](#caveats)
-5. [Details](#details)
-6. [Comparison with Idris's `!`-notation](#comparison-with-idriss--notation)
-
-## Motivating Examples
-
-Let's look at a few examples where Haskell syntax can be a bit annoying when it comes to monads - and what this plugin allows you to write instead:
-
-When you use `Reader` or `State`, you will often have to use `<-` to bind fairly simple expressions:
-
-```haskell
-launchMissile :: StateT Int IO ()
-launchMissile = do
-  count <- get
-  liftIO . putStrLn $ "Missile no. " <> show count <> " has been launched"
-  modify' (+ 1)
-```
-
-```haskell
-help :: Reader Config String
-help = do
-  manualLink <- asks (.links.manual)
-  email <- asks (.contact.email)
-  pure $
-    "You can find help by going to " <> manualLink <>
-    " or writing us at " <> email
-```
-
-With Monadic Bang, you can instead write
-```haskell
-launchMissile :: StateT Int IO ()
-launchMissile = do
-  liftIO . putStrLn $ "Missile no. " <> show !get <> " has been launched"
-  modify' (+ 1)
-```
-
-```haskell
-help :: Reader Config String
-help = do
-  pure $
-    "You can find help by going to " <> (!ask).links.manual <>
-    " or writing us at " <> (!ask).contact.email
-```
-
-With `IORefs`, `STRefs`, mutable arrays, and so on, you'll often have to write code that looks like this, having to use somewhat redundant variable names:
-
-```haskell
-addIORefs :: IORef Int -> IORef Int -> IO Int
-addIORefs aRef bRef = do
-  a <- readIORef aRef
-  b <- readIORef bRef
-  pure $ a + b
-```
-
-With Monadic Bang, you can write
-
-```haskell
-addIORefs :: IORef Int -> IORef Int -> IO Int
-addIORefs a b = do pure $ !(readIORef a) + !(readIORef b)
-```
-
-Implicit parameter definitions have somewhat more limited syntax than regular definitions: You can't write something like `?foo <- action`.  
-That lead me to have to write this in a Vulkan program:
-
-```haskell
-initQueues = do
-  let getQueue = getDeviceQueue ?device
-  graphicsQueue <- getQueue ?graphicsQueueFamily 0
-  presentQueue  <- getQueue ?presentQueueFamily  0
-  computeQueue  <- getQueue ?computeQueueFamily  1
-  let ?graphicsQueue = graphicsQueue
-      ?presentQueue  = presentQueue
-      ?computeQueue  = computeQueue
-  pure Dict
-```
-
-with Monadic Bang, I can write
-
-```haskell
-initQueues = do
-  let getQueue = getDeviceQueue ?device
-  let ?graphicsQueue = !(getQueue ?graphicsQueueFamily 0)
-      ?presentQueue  = !(getQueue ?presentQueueFamily  0)
-      ?computeQueue  = !(getQueue ?computeQueueFamily  1)
-  pure Dict
-```
-
-Take this (slightly adapted) code used for the test suite of this very plugin:
-
-```haskell
-settings :: MonadIO m => m Settings
-settings = ... -- some long function body
-
-initialDynFlags :: MonadIO m => m DynFlags
-initialDynFlags = do
-  settings' <- settings
-  dflags <- defaultDynFlags settings' llvmConfig
-  pure $ dflags{generalFlags = addCompileFlags $ generalFlags dflags}
-```
-
-With this plugin, I can instead write
-
-```haskell
-settings :: MonadIO m => m Settings
-settings = ... -- some long function body
-
-initialDynFlags :: MonadIO m => m DynFlags
-initialDynFlags = do
-  dflags <- defaultDynFlags !settings llvmConfig
-  pure $ dflags{generalFlags = addCompileFlags $ generalFlags dflags}
-```
-
-Or, to take some more code from this plugin's implementation
-
-```haskell
-do logger <- getLogger
-   liftIO $ logMsg logger MCInfo (UnhelpfulSpan UnhelpfulNoLocationInfo) m
-```
-Why have `logger` *and* `getLogger` when you can instead write
-
-```haskell
-do liftIO $ logMsg !getLogger MCInfo (UnhelpfulSpan UnhelpfulNoLocationInfo) m
-```
-
-The pattern you might have noticed here is that this plugin is convenient
-whenever you have a `do`-block with a `<-` that doesn't do pattern matching,
-whose bound variable is only used once, and has a short right-hand side.  While
-that might sound like a lot of qualifiers, it does occur fairly often in
-practice.
-
-## Usage
-
-To use this plugin, you have to add `monadic-bang` to the `build-depends` stanza in your `.cabal` file. Then you can either add `-fplugin=MonadicBang` to the `ghc-options` stanza, or add
-
-```haskell
-{-# OPTIONS_GHC -fplugin=MonadicBang #-}
-```
-
-to the top of the files you want to use it in.
-
-This should also allow HLS to pick up on the plugin, as long as you use HLS 1.9.0.0 or above.
-
-The plugin supports a couple of options, which you can provide via invocations of `-fplugin-opt=MonadicBang:<option>`. The options are:
-
-- `-ddump`: Print the altered AST
-- `-preserve-errors`: Keep parse errors about `!` outside of `do` in their original form, rather than a more relevant explanation. This is mainly useful if another plugin expects those errors.
-
-## Cute Things
-
-### Idiom Brackets Alternative
-
-In some cases where idiom brackets would be ideal, `!` can be a reasonable alternative. For example, compare these four options:
-
-```haskell
-1. liftA2 (&&) (readIORef useMetric) (readIORef useCelsius)
-2. (&&) <$> readIORef useMetric <*> readIORef useCelsius
-   -- hypothetical idiom brackets:
-3. [| readIORef useMetric && readIORef useCelsius |]
-   -- Monadic Bang:
-4. do pure (!(readIORef useMetric) && !(readIORef useCelsius))
-```
-
-while `<$>` and `<*>` are probably better here for prefix functions, `!` plays nicer with infix operators.
-
-If you have `-XApplicativeDo` enabled, this even works with `Applicative` instances.
-
-### Nested `!`
-
-`!` can easily be nested. E.g. you could have
-
-```haskell
-do putStrLn !(readFile (!getArgs !! 1))
-```
-
-For how this is desugared, see [Desugaring](#desugaring).
-
-### Using `-XQualifiedDo`
-
-`!` always has to be used inside a `do`-block, but it *can* be a qualified `do`-block. For example, if you use `-XLinearTypes`, you could write things like
-
-```haskell
-{-# LANGUAGE QualifiedDo, BlockArguments, OverloadedStrings #-}
-import Prelude.Linear
-import Control.Functor.Linear as Linear
-import System.IO.Resource.Linear
-
-main :: IO ()
-main = run Linear.do
-  Linear.pure !(move Linear.<$> hClose !(hPutStrLn !(openFile "tmp" WriteMode) "foo"))
-```
-
-which would be desugared as
-
-```Haskell
-main :: IO ()
-main = run Linear.do
-  a <- openFile "tmp" WriteMode
-  b <- hPutStrLn a "foo"
-  c <- move Linear.<$> hClose b
-  Linear.pure c
-```
-
-### List comprehensions
-
-List comprehensions are essentially just special `do`-blocks, so `!` can be used here as well (as well as in monad comprehensions). Example:
-
-```haskell
-[ x + ![1, 2, 3] | x <- [60, 70, ![800, 900]] ]
-```
-This would be equivalent to
-```haskell
-[ x + b | a <- [800, 900], x <- [60, 70, a], b <- [1, 2, 3]]
-```
-
-The reason `b <- ...` is at the end here instead of the beginning is that everything that appears to the left of the `|` in a list comprehension is essentially treated like the last statement of a `do`-block (+ `pure`).
-
-### Get Rid of `<-`
-
-In principle, every instance of `pattern <- action` in a `do`-block could be replaced by `let pattern = !action`. Should they? That's a separate question, though it could be a viable style.
-
-The implicit parameter example in the first section is a valid use case of this.
-
-### Monadic Variants
-
-Oftentimes, some generic function exists, but then it turns out that a monadic variant of said function would be useful as well. For example, hoogle finds at least a dozen different packages offering `whenM`. With this plugin, you can instead write
-
-```haskell
-main = do
-  when (null !getArgs) $ print usage
-  ...
-```
-
-⚠️ NB: This works here since `when` only needs to evaluate its condition once. If you were to try to replace e.g. one of the forms of `whileM` in this manner, you would run into trouble since it's supposed to evaluate the condition again on each iteration.
-
-## Caveats
-
-There are a few disadvantages to using this that are worth mentioning:
-
-- Since the plugin modifies the source code, the location info in error messages might look a bit strange, since it contains the desugared version. This shouldn't be an issue if you use HLS or another tool to highlight errors within your editor.
-- HLint currently does not work with this plugin (HLint will show you a parse error if you try to use `!`.)
-- If there are fatal parse errors in the source code, unfortunately each `!` will also be highlighted as a parse error. This is unavoidable at the moment, since the plugin can only intercept those messages if the module is otherwise successfully parsed.
-- Plugins like this cannot be used inside of GHCi at this time (however, you can load modules that use it into GHCi).
-- Arguably this makes `do`-desugaring slightly more confusing - e.g., compare the following:
-
-  ```haskell
-  do put 4
-     put 5 >> print !get
-  ``` 
-  
-  ```haskell
-  do put 4
-     put 5
-     print !get
-  ```  
-  
-  With the usual desugaring rules, whether you use `>>` or a new line shouldn't make a difference, but here, the first snippet will print `4`, while the second snippet will print `5`.
-
-  Because of this, the plugin is usually best used in situations where the order in which effects happen makes no difference.
-
-## Details
-
-While the above information should cover most use cases, there are some details that could sometimes be relevant
-
-### Desugaring
-
-The desugaring is essentially what one would expect from comparing the motivating examples with the versions using `!`.
-
-To illustrate with a fairly extensive example:
-
-```haskell
-x = g do
-  foo
-  bar <- !a + !(!b ++ !c)
-  baz <- case !d of
-    (!f -> e) -> do !g e
-```
-
-is desugared into
-
-```haskell
-x = g do
-  foo
-  <!a> <- a
-  <!b> <- b
-  <!c> <- c
-  <!(!b ++ !c)> <- <!b> ++ <!c>
-  bar <- <!a> + <!(!b ++ !c)>
-  <!d> <- d
-  <!f> <- f
-  baz <- case <!d> of
-    (<!f> -> e) -> do
-      <!g> <- g
-      <!g> e
-```
-
-where `<!a>` etc. are simply special variable names.
-
-So, broadly speaking, the order in which things are bound is top-to-bottom (statement-wise), inside-out, and left-to-right.
-
-This can be important when the order of effects matters - though as mentioned above, if order *does* matter, `!` might not be the clearest way to express things.
-
-`!` will only bubble up to the nearest `do`-block. To illustrate:
-
-```haskell
-x = do when nuclearStrikeDetected $ log !launchMissiles
-
-y = do when nuclearStrikeDetected $ do log !launchMissiles
-```
-
-`x` will launch the missiles regardless of whether or not a strike has been detected. But it will only log the results in the case of detection.
-`y` will only launch the missiles (and log the results) if a strike has been detected.
-
-The desugaring:
-
-```haskell
-x = do
-  <!launchMissiles> <- launchMissiles
-  when nuclearStrikeDetected $ log <!launchMissiles>
-
-y = do
-  when nuclearStrikeDetected $ do
-    <!launchMissiles> <- launchMissiles
-    log <!launchMissiles>
-```
-
-The story for `case` and `if` expressions is similar, `!` in the individual branches will *all* be executed unless the branches have their own `do`-blocks.
-
-### Variable scope
-
-A variable can be used inside a `!` if
-- it was bound outside the current `do`-block
-- or it was bound before the statement the `!` is in
-- or it is bound inside the `!`
-
-In other words, this is legal:
-```haskell
-f x = do
-  let a = a
-  foo !(let b = b in x + a + b)
-```
-but this is not:
-```haskell
-c = do
-  let a = a in foo !a
-```
-That's because this would be desugared as
-```haskell
-c = do
-  <!a> <- a
-  let a = a in foo <!a>
-```
-but `a` is not in scope in the second line.
-
-### Where it can be used
-
-It can be used in any expression that is somewhere inside a `do`-block. In particular, this includes for example `where`-blocks in `case`-expressions:
-
-```haskell
-main = do
-  putStrLn case !getLine of
-    "print args" -> prettyArgs "\n"
-      where prettyArgs sep = intercalate sep !getArgs
-    "greeting" -> "hello there!"
-```
-
-and view patterns
-
-```haskell
-do (extract !getSettings -> contents) <- readArchive
-   print contents
-```
-
-## Comparison with Idris's `!`-notation
-
-The main difference is that Idris will insert a `do` if there is none - e.g. this is legal in Idris:
-
-```haskell
-f : IO ()
-f = putStrLn !getLine
-```
-
-but (assuming it's at top-level) wouldn't be with this plugin; you would have to write `f = do putStrLn !getLine` instead.
-
-Some other differences:
-- In Idris, `!`'d expressions cannot escape to outside of a lambda expression (it effectively inserts a new `do` at the beginning of the lambda body instead)
-- The same difference applies to `let` bindings that define functions
+# Monadic Bang++[![Run Tests](https://github.com/JakobBruenker/monadic-bang/actions/workflows/haskell.yml/badge.svg?branch=main&event=push)](https://github.com/JakobBruenker/monadic-bang/actions/workflows/haskell.yml)++This is a GHC Parser plugin for GHC 9.4 and above, intended to make monadic code within `do`-blocks more concise and nicer to work with. Works with HLS.++This is heavily inspired by [Idris's !-notation](https://idris2.readthedocs.io/en/latest/tutorial/interfaces.html#notation), but with some [important differences](#comparison-with-idriss--notation).++## Contents++1. [Motivating Examples](#motivating-examples)+2. [Usage](#usage)+3. [Cute Things](#cute-things)+4. [Caveats](#caveats)+5. [Details](#details)+6. [Comparison with Idris's `!`-notation](#comparison-with-idriss--notation)++## Motivating Examples++Let's look at a few examples where Haskell syntax can be a bit annoying when it comes to monads - and what this plugin allows you to write instead:++When you use `Reader` or `State`, you will often have to use `<-` to bind fairly simple expressions:++```haskell+launchMissile :: StateT Int IO ()+launchMissile = do+  count <- get+  liftIO . putStrLn $ "Missile no. " <> show count <> " has been launched"+  modify' (+ 1)+```++```haskell+help :: Reader Config String+help = do+  manualLink <- asks (.links.manual)+  email <- asks (.contact.email)+  pure $+    "You can find help by going to " <> manualLink <>+    " or writing us at " <> email+```++With Monadic Bang, you can instead write+```haskell+launchMissile :: StateT Int IO ()+launchMissile = do+  liftIO . putStrLn $ "Missile no. " <> show !get <> " has been launched"+  modify' (+ 1)+```++```haskell+help :: Reader Config String+help = do+  pure $+    "You can find help by going to " <> (!ask).links.manual <>+    " or writing us at " <> (!ask).contact.email+```++With `IORefs`, `STRefs`, mutable arrays, and so on, you'll often have to write code that looks like this, having to use somewhat redundant variable names:++```haskell+addIORefs :: IORef Int -> IORef Int -> IO Int+addIORefs aRef bRef = do+  a <- readIORef aRef+  b <- readIORef bRef+  pure $ a + b+```++With Monadic Bang, you can write++```haskell+addIORefs :: IORef Int -> IORef Int -> IO Int+addIORefs a b = do pure $ !(readIORef a) + !(readIORef b)+```++Implicit parameter definitions have somewhat more limited syntax than regular definitions: You can't write something like `?foo <- action`.  +That lead me to have to write this in a Vulkan program:++```haskell+initQueues = do+  let getQueue = getDeviceQueue ?device+  graphicsQueue <- getQueue ?graphicsQueueFamily 0+  presentQueue  <- getQueue ?presentQueueFamily  0+  computeQueue  <- getQueue ?computeQueueFamily  1+  let ?graphicsQueue = graphicsQueue+      ?presentQueue  = presentQueue+      ?computeQueue  = computeQueue+  pure Dict+```++with Monadic Bang, I can write++```haskell+initQueues = do+  let getQueue = getDeviceQueue ?device+  let ?graphicsQueue = !(getQueue ?graphicsQueueFamily 0)+      ?presentQueue  = !(getQueue ?presentQueueFamily  0)+      ?computeQueue  = !(getQueue ?computeQueueFamily  1)+  pure Dict+```++Take this (slightly adapted) code used for the test suite of this very plugin:++```haskell+settings :: MonadIO m => m Settings+settings = ... -- some long function body++initialDynFlags :: MonadIO m => m DynFlags+initialDynFlags = do+  settings' <- settings+  dflags <- defaultDynFlags settings' llvmConfig+  pure $ dflags{generalFlags = addCompileFlags $ generalFlags dflags}+```++With this plugin, I can instead write++```haskell+settings :: MonadIO m => m Settings+settings = ... -- some long function body++initialDynFlags :: MonadIO m => m DynFlags+initialDynFlags = do+  dflags <- defaultDynFlags !settings llvmConfig+  pure $ dflags{generalFlags = addCompileFlags $ generalFlags dflags}+```++Or, to take some more code from this plugin's implementation++```haskell+do logger <- getLogger+   liftIO $ logMsg logger MCInfo (UnhelpfulSpan UnhelpfulNoLocationInfo) m+```+Why have `logger` *and* `getLogger` when you can instead write++```haskell+do liftIO $ logMsg !getLogger MCInfo (UnhelpfulSpan UnhelpfulNoLocationInfo) m+```++The pattern you might have noticed here is that this plugin is convenient+whenever you have a `do`-block with a `<-` that doesn't do pattern matching,+whose bound variable is only used once, and has a short right-hand side.  While+that might sound like a lot of qualifiers, it does occur fairly often in+practice.++## Usage++To use this plugin, you have to add `monadic-bang` to the `build-depends` stanza in your `.cabal` file. Then you can either add `-fplugin=MonadicBang` to the `ghc-options` stanza, or add++```haskell+{-# OPTIONS_GHC -fplugin=MonadicBang #-}+```++to the top of the files you want to use it in.++This should also allow HLS to pick up on the plugin, as long as you use HLS 1.9.0.0 or above.++The plugin supports a couple of options, which you can provide via invocations of `-fplugin-opt=MonadicBang:<option>`. The options are:++- `-ddump`: Print the altered AST+- `-preserve-errors`: Keep parse errors about `!` outside of `do` in their original form, rather than a more relevant explanation. This is mainly useful if another plugin expects those errors.++## Cute Things++### Idiom Brackets Alternative++In some cases where idiom brackets would be ideal, `!` can be a reasonable alternative. For example, compare these four options:++```haskell+1. liftA2 (&&) (readIORef useMetric) (readIORef useCelsius)+2. (&&) <$> readIORef useMetric <*> readIORef useCelsius+   -- hypothetical idiom brackets:+3. [| readIORef useMetric && readIORef useCelsius |]+   -- Monadic Bang:+4. do pure (!(readIORef useMetric) && !(readIORef useCelsius))+```++while `<$>` and `<*>` are probably better here for prefix functions, `!` plays nicer with infix operators.++If you have `-XApplicativeDo` enabled, this even works with `Applicative` instances.++### Nested `!`++`!` can easily be nested. E.g. you could have++```haskell+do putStrLn !(readFile (!getArgs !! 1))+```++For how this is desugared, see [Desugaring](#desugaring).++### Using `-XQualifiedDo`++`!` always has to be used inside a `do`-block, but it *can* be a qualified `do`-block. For example, if you use `-XLinearTypes`, you could write things like++```haskell+{-# LANGUAGE QualifiedDo, BlockArguments, OverloadedStrings #-}+import Prelude.Linear+import Control.Functor.Linear as Linear+import System.IO.Resource.Linear++main :: IO ()+main = run Linear.do+  Linear.pure !(move Linear.<$> hClose !(hPutStrLn !(openFile "tmp" WriteMode) "foo"))+```++which would be desugared as++```Haskell+main :: IO ()+main = run Linear.do+  a <- openFile "tmp" WriteMode+  b <- hPutStrLn a "foo"+  c <- move Linear.<$> hClose b+  Linear.pure c+```++### List comprehensions++List comprehensions are essentially just special `do`-blocks, so `!` can be used here as well (as well as in monad comprehensions). Example:++```haskell+[ x + ![1, 2, 3] | x <- [60, 70, ![800, 900]] ]+```+This would be equivalent to+```haskell+[ x + b | a <- [800, 900], x <- [60, 70, a], b <- [1, 2, 3]]+```++The reason `b <- ...` is at the end here instead of the beginning is that everything that appears to the left of the `|` in a list comprehension is essentially treated like the last statement of a `do`-block (+ `pure`).++### Get Rid of `<-`++In principle, every instance of `pattern <- action` in a `do`-block could be replaced by `let pattern = !action`. Should they? That's a separate question, though it could be a viable style.++The implicit parameter example in the first section is a valid use case of this.++### Monadic Variants++Oftentimes, some generic function exists, but then it turns out that a monadic variant of said function would be useful as well. For example, hoogle finds at least a dozen different packages offering `whenM`. With this plugin, you can instead write++```haskell+main = do+  when (null !getArgs) $ print usage+  ...+```++⚠️ NB: This works here since `when` only needs to evaluate its condition once. If you were to try to replace e.g. one of the forms of `whileM` in this manner, you would run into trouble since it's supposed to evaluate the condition again on each iteration.++## Caveats++There are a few disadvantages to using this that are worth mentioning:++- Since the plugin modifies the source code, the location info in error messages might look a bit strange, since it contains the desugared version. This shouldn't be an issue if you use HLS or another tool to highlight errors within your editor.+- HLint currently does not work with this plugin (HLint will show you a parse error if you try to use `!`.)+- If there are fatal parse errors in the source code, unfortunately each `!` will also be highlighted as a parse error. This is unavoidable at the moment, since the plugin can only intercept those messages if the module is otherwise successfully parsed.+- Plugins like this cannot be used inside of GHCi at this time (however, you can load modules that use it into GHCi).+- Arguably this makes `do`-desugaring slightly more confusing - e.g., compare the following:++  ```haskell+  do put 4+     put 5 >> print !get+  ``` +  +  ```haskell+  do put 4+     put 5+     print !get+  ```  +  +  With the usual desugaring rules, whether you use `>>` or a new line shouldn't make a difference, but here, the first snippet will print `4`, while the second snippet will print `5`.++  Because of this, the plugin is usually best used in situations where the order in which effects happen makes no difference.++## Details++While the above information should cover most use cases, there are some details that could sometimes be relevant++### Desugaring++The desugaring is essentially what one would expect from comparing the motivating examples with the versions using `!`.++To illustrate with a fairly extensive example:++```haskell+x = g do+  foo+  bar <- !a + !(!b ++ !c)+  baz <- case !d of+    (!f -> e) -> do !g e+```++is desugared into++```haskell+x = g do+  foo+  <!a> <- a+  <!b> <- b+  <!c> <- c+  <!(!b ++ !c)> <- <!b> ++ <!c>+  bar <- <!a> + <!(!b ++ !c)>+  <!d> <- d+  <!f> <- f+  baz <- case <!d> of+    (<!f> -> e) -> do+      <!g> <- g+      <!g> e+```++where `<!a>` etc. are simply special variable names.++So, broadly speaking, the order in which things are bound is top-to-bottom (statement-wise), inside-out, and left-to-right.++This can be important when the order of effects matters - though as mentioned above, if order *does* matter, `!` might not be the clearest way to express things.++`!` will only bubble up to the nearest `do`-block. To illustrate:++```haskell+x = do when nuclearStrikeDetected $ log !launchMissiles++y = do when nuclearStrikeDetected $ do log !launchMissiles+```++`x` will launch the missiles regardless of whether or not a strike has been detected. But it will only log the results in the case of detection.+`y` will only launch the missiles (and log the results) if a strike has been detected.++The desugaring:++```haskell+x = do+  <!launchMissiles> <- launchMissiles+  when nuclearStrikeDetected $ log <!launchMissiles>++y = do+  when nuclearStrikeDetected $ do+    <!launchMissiles> <- launchMissiles+    log <!launchMissiles>+```++The story for `case` and `if` expressions is similar, `!` in the individual branches will *all* be executed unless the branches have their own `do`-blocks.++### Variable scope++A variable can be used inside a `!` if+- it was bound outside the current `do`-block+- or it was bound before the statement the `!` is in+- or it is bound inside the `!`++In other words, this is legal:+```haskell+f x = do+  let a = a+  foo !(let b = b in x + a + b)+```+but this is not:+```haskell+c = do+  let a = a in foo !a+```+That's because this would be desugared as+```haskell+c = do+  <!a> <- a+  let a = a in foo <!a>+```+but `a` is not in scope in the second line.++### Where it can be used++It can be used in any expression that is somewhere inside a `do`-block. In particular, this includes for example `where`-blocks in `case`-expressions:++```haskell+main = do+  putStrLn case !getLine of+    "print args" -> prettyArgs "\n"+      where prettyArgs sep = intercalate sep !getArgs+    "greeting" -> "hello there!"+```++and view patterns++```haskell+do (extract !getSettings -> contents) <- readArchive+   print contents+```++## Comparison with Idris's `!`-notation++The main difference is that Idris will insert a `do` if there is none - e.g. this is legal in Idris:++```haskell+f : IO ()+f = putStrLn !getLine+```++but (assuming it's at top-level) wouldn't be with this plugin; you would have to write `f = do putStrLn !getLine` instead.++Some other differences:+- In Idris, `!`'d expressions cannot escape to outside of a lambda expression (it effectively inserts a new `do` at the beginning of the lambda body instead)+- The same difference applies to `let` bindings that define functions

@@ -1,130 +1,132 @@-cabal-version:      2.4
-
--- Initial package description 'monadic-bang.cabal' generated by
--- 'cabal init'. For further documentation, see:
---   http://haskell.org/cabal/users-guide/
---
--- The name of the package.
-name:               monadic-bang
-
--- The package version.
--- See the Haskell package versioning policy (PVP) for standards
--- guiding when and how versions should be incremented.
--- https://pvp.haskell.org
--- PVP summary:      +-+------- breaking API changes
---                   | | +----- non-breaking API additions
---                   | | | +--- code changes with no API change
-version:            0.2.2.2
-
--- A short (one-line) description of the package.
-synopsis:           GHC plugin to desugar ! into do-notation
-
--- A longer description of the package.
-description:        A plugin for GHC which takes expressions prefixed with a !
-                    and effectively takes them out of their monadic context, by
-                    creating bind statements in the do-block surrounding the
-                    expression. Inspired by Idris's !-notation. For more
-                    information, see README.md.
-
--- URL for the project homepage or repository.
-homepage:           https://github.com/JakobBruenker/monadic-bang
-
--- A URL where users can report bugs.
-bug-reports:        https://github.com/JakobBruenker/monadic-bang/issues
-
--- The license under which the package is released.
-license:            MIT
-
--- The package author(s).
-author:             Jakob Brünker
-
--- An email address to which users can send suggestions, bug reports, and patches.
-maintainer:         jakob.bruenker@gmail.com
-
--- A copyright notice.
--- copyright:
-category:           Development
-
-extra-doc-files:
-    CHANGELOG.md
-    README.md
-
-tested-with:        GHC == 9.4.7
-                    GHC == 9.6.3
-                    GHC == 9.8.1
-                    GHC == 9.10.1
-                    GHC == 9.12.1
-
-source-repository head
-    type:           git
-    location:       https://github.com/JakobBruenker/monadic-bang.git
-
-library
-    -- Modules exported by the library.
-    exposed-modules:  MonadicBang
-                      MonadicBang.Internal
-                      MonadicBang.Internal.Effect.Offer
-                      MonadicBang.Internal.Effect.Uniques
-                      MonadicBang.Internal.Effect.Writer.Discard
-                      MonadicBang.Internal.Options
-                      MonadicBang.Internal.Utils
-                      MonadicBang.Internal.Error
-
-    -- Modules included in this library but not exported.
-    -- other-modules:
-
-    -- LANGUAGE extensions used by modules in this package.
-    other-extensions: ScopedTypeVariables,
-                      BlockArguments,
-                      LambdaCase,
-                      GADTs,
-                      RecordWildCards,
-                      OverloadedRecordDot,
-                      NoFieldSelectors,
-                      ViewPatterns,
-                      StrictData,
-                      PatternSynonyms
-
-    -- Other library packages from which modules are imported.
-    build-depends:    base >=4.17.0.0 && <4.22,
-                      ghc >=9.4 && <9.13,
-                      containers ^>=0.6.4.1 || ^>=0.7,
-                      transformers >=0.5.6.2 && <0.7,
-                      fused-effects ^>=1.1.1.2
-
-    -- Directories containing source files.
-    hs-source-dirs:   src
-
-    -- Base language which the package is written in.
-    default-language: GHC2021
-
-    ghc-options:      -Wall -Wcompat
-
-test-suite monadic-bang-test
-    -- Base language which the package is written in.
-    default-language: GHC2021
-
-    -- The interface type and version of the test suite.
-    type:             exitcode-stdio-1.0
-
-    -- Directories containing source files.
-    hs-source-dirs:   test
-
-    -- The entrypoint to the test suite.
-    main-is:          MonadicBang/Test.hs
-
-    other-modules:    MonadicBang.Test.Utils.RunGhcParser
-                      MonadicBang.Test.Utils.QualifiedDo
-                      MonadicBang.Test.Utils
-                      MonadicBang.Test.ShouldPass
-                      MonadicBang.Test.ShouldFail
-
-    -- Test dependencies.
-    build-depends:    base,
-                      ghc,
-                      ghc-boot >=9.4 && <9.13,
-                      ghc-paths ^>=0.1.0.12,
-                      transformers,
-                      monadic-bang
-
-    ghc-options:      -Wall -Wcompat -plugin-package=monadic-bang
+cabal-version:      2.4++-- Initial package description 'monadic-bang.cabal' generated by+-- 'cabal init'. For further documentation, see:+--   http://haskell.org/cabal/users-guide/+--+-- The name of the package.+name:               monadic-bang++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:            0.2.2.3++-- A short (one-line) description of the package.+synopsis:           GHC plugin to desugar ! into do-notation++-- A longer description of the package.+description:        A plugin for GHC which takes expressions prefixed with a !+                    and effectively takes them out of their monadic context, by+                    creating bind statements in the do-block surrounding the+                    expression. Inspired by Idris's !-notation. For more+                    information, see README.md.++-- URL for the project homepage or repository.+homepage:           https://github.com/JakobBruenker/monadic-bang++-- A URL where users can report bugs.+bug-reports:        https://github.com/JakobBruenker/monadic-bang/issues++-- The license under which the package is released.+license:            MIT++-- The package author(s).+author:             Jakob Brünker++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer:         jakob.bruenker@gmail.com++-- A copyright notice.+-- copyright:+category:           Development++extra-doc-files:+    CHANGELOG.md+    README.md++tested-with:        GHC == 9.4.7+                    GHC == 9.6.3+                    GHC == 9.8.1+                    GHC == 9.10.1+                    GHC == 9.12.1+                    GHC == 9.14.1++source-repository head+    type:           git+    location:       https://github.com/JakobBruenker/monadic-bang.git++library+    -- Modules exported by the library.+    exposed-modules:  MonadicBang+                      MonadicBang.Internal+                      MonadicBang.Internal.Effect.Offer+                      MonadicBang.Internal.Effect.Uniques+                      MonadicBang.Internal.Effect.Writer.Discard+                      MonadicBang.Internal.Options+                      MonadicBang.Internal.Utils+                      MonadicBang.Internal.Error++    -- Modules included in this library but not exported.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    other-extensions: ScopedTypeVariables,+                      BlockArguments,+                      LambdaCase,+                      GADTs,+                      RecordWildCards,+                      OverloadedRecordDot,+                      NoFieldSelectors,+                      ViewPatterns,+                      StrictData,+                      PatternSynonyms++    -- Other library packages from which modules are imported.+    build-depends:    base >=4.17.0.0 && <4.23,+                      ghc >=9.4 && <9.15,+                      containers ^>=0.6.4.1 || ^>=0.7 || ^>=0.8,+                      transformers >=0.5.6.2 && <0.7,+                      fused-effects ^>=1.1.1.2++    -- Directories containing source files.+    hs-source-dirs:   src++    -- Base language which the package is written in.+    default-language: GHC2021++    ghc-options:      -Wall -Wcompat++test-suite monadic-bang-test+    -- Base language which the package is written in.+    default-language: GHC2021++    -- The interface type and version of the test suite.+    type:             exitcode-stdio-1.0++    -- Directories containing source files.+    hs-source-dirs:   test++    -- The entrypoint to the test suite.+    main-is:          MonadicBang/Test.hs++    other-modules:    MonadicBang.Test.Utils.RunGhcParser+                      MonadicBang.Test.Utils.QualifiedDo+                      MonadicBang.Test.Utils+                      MonadicBang.Test.ShouldPass+                      MonadicBang.Test.ShouldFail++    -- Test dependencies.+    build-depends:    base,+                      ghc,+                      ghc-boot >=9.4 && <9.15,+                      ghc-paths ^>=0.1.0.12,+                      transformers,+                      filepath,+                      monadic-bang++    ghc-options:      -Wall -Wcompat -plugin-package=monadic-bang

@@ -1,13 +1,13 @@--- | GHC plugin to desugar ! into do-notation
---
--- For more information, please refer to the README.
-module MonadicBang (plugin) where
-
-import GHC.Plugins
-import MonadicBang.Internal
-
-plugin :: Plugin
-plugin = defaultPlugin
-  { parsedResultAction = replaceBangs
-  , pluginRecompile = purePlugin
-  }
+-- | GHC plugin to desugar ! into do-notation+--+-- For more information, please refer to the README.+module MonadicBang (plugin) where++import GHC.Plugins+import MonadicBang.Internal++plugin :: Plugin+plugin = defaultPlugin+  { parsedResultAction = replaceBangs+  , pluginRecompile = purePlugin+  }

@@ -1,468 +1,472 @@-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE NoFieldSelectors #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE StrictData #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE CPP #-}
-
-module MonadicBang.Internal where
-
-import Prelude hiding (log)
-import Control.Applicative
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.Identity
-import Control.Carrier.Reader
-import Control.Carrier.Writer.Strict
-import Control.Carrier.State.Strict
-import Control.Carrier.Throw.Either
-import Control.Carrier.Lift
-import Control.Effect.Sum hiding (L)
-import Control.Exception hiding (try, handle, Handler)
-import Data.Data
-import Data.Foldable
-import Data.Functor
-import Data.Map.Strict (Map)
-import Data.Map.Strict qualified as M
-import Data.Monoid
-import GHC hiding (Type)
-import GHC.Data.Bag
-import GHC.Data.Maybe
-import GHC.Parser.Errors.Types
-import GHC.Plugins hiding (Type, Expr, empty, (<>), panic, try)
-import GHC.Types.Error
-import GHC.Utils.Monad (concatMapM, whenM)
-import Text.Printf
-
-import GHC.Utils.Logger
-
-import MonadicBang.Internal.Effect.Offer
-import MonadicBang.Internal.Effect.Uniques
-import MonadicBang.Internal.Options
-import MonadicBang.Internal.Utils
-import MonadicBang.Internal.Error
-import MonadicBang.Internal.Effect.Writer.Discard
-
-import Data.Kind
-import Data.Coerce
-
--- We don't care about which file things are from, because the entire AST comes
--- from the same module
-data Loc = MkLoc {line :: Int, col :: Int}
-         deriving (Eq, Ord, Show)
-
-type Expr = HsExpr GhcPs
-type LExpr = LHsExpr GhcPs
-
--- | OccSet newtype that allows us to define an orphan Monoid instance
-newtype Occs = MkOccs OccSet
-
-instance Semigroup Occs where
-  (<>) = coerce unionOccSets
-
-instance Monoid Occs where
-  mempty = emptyOccs
-
-emptyOccs :: Occs
-emptyOccs = coerce emptyOccSet
-
-extendOccs :: Occs -> OccName -> Occs
-extendOccs = coerce extendOccSet
-
-elemOccs :: OccName -> Occs -> Bool
-elemOccs = coerce elemOccSet
-
-unitOccs :: OccName -> Occs
-unitOccs = coerce unitOccSet
-
--- | To keep track of which local variables in scope may be used
---
--- If local variables are defined within the same statement as a !, but outside
--- of that !, they must not be used within this !, since their desugaring would
--- make them escape their scope.
-data InScope = MkInScope {valid :: Occs , invalid :: Occs}
-
-instance Semigroup InScope where
-  a <> b = MkInScope{valid = a.valid <> b.valid, invalid = a.invalid <> b.invalid}
-
-instance Monoid InScope where
-  mempty = noneInScope
-
-noneInScope :: InScope
-noneInScope = MkInScope emptyOccs emptyOccs
-
-addValid :: OccName -> InScope -> InScope
-addValid name inScope = inScope{valid = extendOccs inScope.valid name}
-
-addValids :: Occs -> InScope -> InScope
-addValids names inScope = inScope{valid = inScope.valid <> names}
-
-invalidateVars :: InScope -> InScope
-invalidateVars inScope = MkInScope{valid = emptyOccs, invalid = inScope.valid <> inScope.invalid}
-
-isInvalid :: Has (Reader InScope) sig m => OccName -> m Bool
-isInvalid name = do
-  inScope <- ask @InScope
-  pure $ name `elemOccs` inScope.invalid
-
--- | Decrement column by one to get the location of a !
-bangLoc :: Loc -> Loc
-bangLoc loc = loc{col = loc.col - 1}
-
--- | Decrement start by one column to get the location of a !
-bangSpan :: SrcSpan -> SrcSpan
-bangSpan sp = mkSrcSpan (bangSrcLoc $ srcSpanStart sp) (srcSpanEnd sp)
-
--- | Decrement column by one to get the location of a !
-bangSrcLoc :: SrcLoc -> SrcLoc
-bangSrcLoc = \cases
-  l@(UnhelpfulLoc _) -> l
-  (RealSrcLoc srcLoc _) -> liftA3 mkSrcLoc srcLocFile srcLocLine (pred . srcLocCol) srcLoc
-
--- | Used to extract the Loc of a located expression
-pattern ExprLoc :: Loc -> Expr -> LExpr
-pattern ExprLoc loc expr <- L (locA -> RealSrcSpan (spanToLoc -> loc) _) expr
-
-spanToLoc :: RealSrcSpan -> Loc
-spanToLoc = liftA2 MkLoc srcLocLine srcLocCol . realSrcSpanStart
-
-replaceBangs :: [CommandLineOption] -> ModSummary -> Handler Hsc ParsedResult
-replaceBangs cmdLineOpts _ orig@(ParsedResult (HsParsedModule mod' files) msgs)
-  | null fills = pure orig
-  | otherwise = do
-    options <- liftIO . (either throwIO pure =<<) . runThrow @ErrorCall $ parseOptions mod' cmdLineOpts
-    dflags <- getDynFlags
-    (newErrors, mod'') <-
-      runM .
-      runUniquesIO 'p' .
-      runWriter .
-      runReader options .
-      runReader noneInScope .
-      evalWriter @Occs .
-      runReader dflags $
-      fillHoles fills mod'
-    log options.verbosity (ppr mod'')
-    pure $ ParsedResult (HsParsedModule mod'' files) msgs{psErrors = oldErrors <> newErrors}
-  where
-    log = \cases
-      Quiet _ -> pure ()
-      DumpTransformed m -> do
-        logger <- getLogger
-        liftIO $ logMsg logger MCInfo (UnhelpfulSpan UnhelpfulNoLocationInfo) m
-
-    -- Extract the errors we care about, throw the rest back in
-    (mkMessages -> oldErrors, M.fromList . bagToList -> fills) =
-      (partitionBagWith ?? msgs.psErrors.getMessages) \cases
-        err | PsErrBangPatWithoutSpace lexpr@(ExprLoc (bangLoc -> loc) _) <- err.errMsgDiagnostic
-            -> Right (loc, lexpr)
-            | otherwise -> Left err
-                  
-type HandleFailure :: Bool -> (Type -> Type) -> (Type -> Type)
-type family HandleFailure canFail = t | t -> canFail where
-  HandleFailure True = MaybeT
-  HandleFailure False = IdentityT
-
-class MonadTrans t => HandlingMonadTrans t where
-  toMaybeT :: Monad m => t m a -> MaybeT m a
-
-instance HandlingMonadTrans IdentityT where
-  toMaybeT = MaybeT . fmap Just . runIdentityT 
-
-instance HandlingMonadTrans MaybeT where
-  toMaybeT = id
-
-class Typeable (AstType a) => Handle a where
-  type CanFail a :: Bool
-  type AstType a = (r :: Type) | r -> a
-  type Effects a :: (Type -> Type) -> Type -> Type
-  handle' :: forall sig m m' . m ~ HandleFailure (CanFail a) m' => Has (Effects a) sig m' => Handler m (AstType a)
-
-handle :: forall a sig m . (Handle a, CanFail a ~ False) => Has (Effects a) sig m => Handler m (AstType a)
-handle = runIdentityT . handle'
-
-try :: forall e sig m a .
-       (HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a, Handle e, Monad m, Has (Effects e) sig m) =>
-       Try m a
-try x = do
-  Refl <- hoistMaybe $ eqT @a @(AstType e)
-  toMaybeT $ handle' x
-
-instance Handle GRHSs where
-  type CanFail GRHSs = False
-  type AstType GRHSs = GRHSs GhcPs LExpr
-  type Effects GRHSs = Fill
-  handle' grhss = do
-    patVars <- ask @InScope
-    grhssLocalBinds <- local (<> patVars) $ evac grhss.grhssLocalBinds
-    grhssGRHSs <- evalState patVars $ evacPats grhss.grhssGRHSs
-    pure grhss{grhssGRHSs, grhssLocalBinds}
-
-instance Handle MatchGroup where
-  type CanFail MatchGroup = False
-  type AstType MatchGroup = MatchGroup GhcPs LExpr
-  type Effects MatchGroup = Fill
-  handle' mg = do
-    mg_alts <- (traverse . traverse . traverse) handle mg.mg_alts
-    pure mg{mg_alts}
-
-instance Handle Match where
-  type CanFail Match = False
-  type AstType Match = Match GhcPs LExpr
-  type Effects Match = Fill
-  handle' match = do
-    -- We use the State to keep track of the bindings that have been
-    -- introduced in patterns to the left of the one we're currently looking
-    -- at. Example:
-    --
-    -- > \a (Just [b, (+ b) -> d]) (foldr a b -> c) | Just f <- b, f == 24
-    --
-    -- the view pattern on `c` has access to the variables to the left of it. The same applies to `d`.
-    -- `f == 24` additionally has access to variables defined in the guard to its left.
-    (patVars, m_pats) <- ask @InScope >>= runState ?? evacPats match.m_pats
-    m_grhss <- local (<> patVars) $ handle match.m_grhss
-    pure match{m_pats, m_grhss}
-
--- | We keep track of any local binds, to prevent the user from using them
--- with ! in situations where they would be evacuated to a place where
--- they're not in scope
---
--- The plugin would still work without this, but might accept programs that
--- shouldn't be accepted, with unexpected semantics. E.g:
---
--- > do let s = pure "outer"
--- >    let s = pure "inner" in putStrLn !s
---
--- You might expect this to print `inner`, but it would actually print
--- `outer`, since it would be desugared to
---
--- > do let s = pure "outer"
--- >    <!s> <- s
--- >    let s = pure "inner" in print <!s>
---
--- With this function, the plugin will instead throw an error saying that
--- `s` cannot be used here.
---
--- If the first `s` weren't defined, the user would, without this function,
--- get an error saying that `s` is not in scope, at the call site. Here,
--- we instead throw a more informative error.
---
--- If only the first `s` were defined, i.e.
---
--- > do let s = pure "outer"
--- >    putStrLn !s
---
--- it would be valid code.
-
-instance Handle HsBindLR where
-  type CanFail HsBindLR = True
-  type AstType HsBindLR = HsBindLR GhcPs GhcPs
-  type Effects HsBindLR = Fill
-  handle' bind = case bind of
-    FunBind{fun_id = occName . unLoc -> name, fun_matches = matches} -> do
-      tellLocalVar name
-      fun_matches <- local (addValid name) $ handle matches
-      pure bind{fun_matches}
-    PatBind{pat_lhs = lhs, pat_rhs = rhs} -> do
-      (binds, pat_lhs) <- ask @InScope >>= flip runState (traverse evacPats lhs)
-      pat_rhs <- local (<> binds) $ handle rhs
-      pure bind{pat_lhs, pat_rhs}
-    -- All VarBinds are introduced by the type checker, but we might as well handle them
-    VarBind{var_id = occName -> name, var_rhs = expr} -> do
-      tellLocalVar name
-      var_rhs <- local (addValid name) $ evac expr
-      pure bind{var_rhs}
-    -- Pattern synonyms can never appear inside of do blocks, so we don't have
-    -- to handle them specially
-    PatSynBind{} -> empty
-
-instance Handle Pat where
-  type CanFail Pat = True
-  type AstType Pat = Pat GhcPs
-  type Effects Pat = Fill :+: State InScope
-  handle' = \case
-    VarPat xv name -> tellName name $> VarPat xv name
-#if MIN_VERSION_ghc(9,10,0)
-    AsPat xa name pat -> do
-      tellName name
-      AsPat xa name <$> traverse (liftMaybeT . evacPats) pat
-#elif MIN_VERSION_ghc(9,6,0)
-    AsPat xa name tok pat -> do
-      tellName name
-      AsPat xa name tok <$> traverse (liftMaybeT . evacPats) pat
-#else
-    AsPat xa name pat -> do
-      tellName name
-      AsPat xa name <$> traverse (liftMaybeT . evacPats) pat
-#endif
-
-    _ -> empty
-    where
-      tellName (occName . unLoc -> name) = do
-        tellLocalVar name
-        modify $ addValid name
-
-instance Handle HsExpr where
-  type CanFail HsExpr = True
-  type AstType HsExpr = GenLocated SrcSpanAnnA Expr
-  type Effects HsExpr = Fill
-  handle' e@(L l _) = do
-    ExprLoc loc expr <- pure e
-    case expr of
-      -- Replace holes resulting from `!`
-      -- If no corresponding expression can be found in the Offer, we assume
-      -- that it was a hole put there by the user and leave it unmodified
-      HsUnboundVar _ _ -> yoink loc >>= maybe (pure e) \lexpr -> do
-        -- all existing valid local variables now become invalid, since using
-        -- them would make them escape their scope
-        lexpr' <- local invalidateVars $ evac lexpr
-        name <- bangVar lexpr' loc
-        tellOne $ name :<- lexpr'
-        pure . L l $ HsVar noExtField (noLocA name)
-      HsVar _ (occName . unLoc -> name) -> do
-        whenM (isInvalid name) do tellPsError (customError $ ErrOutOfScopeVariable name) (locA l)
-        pure e
-      -- In HsDo, we can discard all in-scope variables in the context, since
-      -- any !-desugaring we encounter cannot escape outside of this
-      -- 'do'-block, and thus also not outside of the scope of those
-      -- variables
-      HsDo xd ctxt stmts -> L l . HsDo xd ctxt <$> local (const noneInScope) (traverse addStmts stmts)
-#if MIN_VERSION_ghc(9,10,0)
-      HsLet xl binds ex -> do
-        (boundVars, binds') <- runWriter @Occs $ evac binds
-        fmap (L l . HsLet xl binds') <$> liftMaybeT . local (addValids boundVars) $ evac ex
-#else
-      HsLet xl letTok binds inTok ex -> do
-        (boundVars, binds') <- runWriter @Occs $ evac binds
-        fmap (L l . HsLet xl letTok binds' inTok) <$> liftMaybeT . local (addValids boundVars) $ evac ex
-#endif
-
-      _ -> empty
-
-instance Handle StmtLR where
-  type CanFail StmtLR = True
-  type AstType StmtLR = StmtLR GhcPs GhcPs LExpr
-  type Effects StmtLR = Fill
-  handle' :: forall sig m m' . (m ~ MaybeT m', Has (Effects StmtLR) sig m') => Handler m (AstType StmtLR)
-  handle' e = case e of
-
-    RecStmt{recS_stmts} -> do
-      recS_stmts' <- traverse addStmts recS_stmts
-      pure e{recS_stmts = recS_stmts'}
-    ParStmt xp stmtBlocks zipper bind -> do
-      stmtsBlocks' <- traverse addParStmts stmtBlocks
-      pure $ ParStmt xp stmtsBlocks' zipper bind
-      where
-        addParStmts :: Handler m (ParStmtBlock GhcPs GhcPs)
-        addParStmts (ParStmtBlock xb stmts vars ret) = do
-          stmts' <- addStmts stmts
-          pure $ ParStmtBlock xb stmts' vars ret
-
-    _ -> empty
-
--- | Replace holes in an AST whenever an expression with the corresponding
--- source span can be found in the given list.
-fillHoles :: (Data a, Has (PsErrors :+: Reader Options :+: Uniques :+: LocalVars :+: Reader DynFlags) sig m) => Map Loc LExpr -> Handler m a
-fillHoles fillers ast = do
-  (remainingErrs, (fromDList -> (binds :: [BindStmt]), ast')) <- runOffer fillers . runWriter $ evac ast
-  MkOptions{preserveErrors} <- ask
-  for_ binds \bind -> tellPsError (psError (bindStmtExpr bind) preserveErrors) (bangSpan $ bindStmtSpan bind)
-  dflags <- ask
-  pure if null remainingErrs
-    then ast'
-    else panic $ unlines $ "Found extraneous bangs:" : (showPpr dflags <$> toList remainingErrs)
-  where
-    psError expr = \cases
-      Preserve      -> PsErrBangPatWithoutSpace expr
-      Don'tPreserve -> customError ErrBangOutsideOfDo
-
-evac :: forall a sig m . (Has Fill sig m, Data a) => Handler m a
--- This recurses over all nodes in the AST, except for nodes for which
--- one of the `try` functions returns `Just <something>`.
-evac e = maybe (gmapM evac e) pure =<< runMaybeT (tryEvac usualTries e)
-
-tryEvac :: Monad m => [Try m a] -> Try m a
-tryEvac tries = asum . (tries ??)
-
-usualTries :: (Has Fill sig m, Data a) => [Try m a]
-usualTries =
-  [ try @HsExpr, try @HsBindLR, try @MatchGroup, try @StmtLR
-  , ignore @RdrName, ignore @OccName, ignore @RealSrcSpan, ignore @EpAnnComments
-  ]
-
--- As a minor performance optimization, we don't recurse over the AST if the node
--- is a type that we know will never contain an expression
-ignore :: forall (e :: Type) m a . (Monad m, Typeable a, Typeable e) => Try m a
-ignore e = do
-  Refl <- hoistMaybe $ eqT @e @a
-  pure e
-
--- | evacuate !s in pattern and collect all the names it binds
-evacPats :: forall a m sig . (Has (Fill :+: State InScope) sig m, Data a) => Handler m a
-evacPats e = do
-  currentState <- get @InScope
-  maybe (gmapM evacPats e) pure =<< runMaybeT (tryEvac ((local (<> currentState) .) <$> (try @Pat : usualTries)) e)
-
--- | Find all !s in the given statements and combine the resulting bind
--- statements into lists, with the original statements being the last one
--- in each list - then concatenate these lists
-addStmts :: forall sig m . Has (PsErrors :+: HoleFills :+: Uniques :+: LocalVars :+: Reader DynFlags) sig m => Handler m [ExprLStmt GhcPs]
-addStmts = concatMapM \lstmt -> do
-  (fromDList -> stmts, lstmt') <- runWriter $ evac lstmt
-  pure $ map fromBindStmt stmts ++ [lstmt']
-
-type HoleFills = Offer Loc LExpr
--- | We keep track of variables that are bound in lambdas, cases, etc., since
--- these are variables that will not be accessible in the surrounding
--- 'do'-block, and must therefore not be used.
--- The Reader is used to find out what local variables are in scope, the Writer
--- is used to inform callers which local variables have been bound.
-type LocalVars = Reader InScope :+: Writer Occs
-
-type Fill = PsErrors :+: Writer (DList BindStmt) :+: HoleFills :+: Uniques :+: LocalVars :+: Reader DynFlags
-
-data BindStmt = RdrName :<- LExpr
-
-bindStmtExpr :: BindStmt -> LExpr
-bindStmtExpr (_ :<- expr) = expr
-
-bindStmtSpan :: BindStmt -> SrcSpan
-bindStmtSpan = locA . \(_ :<- L l _) -> l
-
-fromBindStmt :: BindStmt -> ExprLStmt GhcPs
-fromBindStmt = noLocA . \cases
-  (var :<- lexpr) -> BindStmt noAnn varPat lexpr
-    where
-      varPat = noLocA . VarPat noExtField $ noLocA var
-
--- | Use the !'d expression if it's short enough, or else abbreviate with `...`
--- We don't need to worry about shadowing other !'d expressions:
--- - For the user, we add line and column numbers to the name
--- - For the compiler, we use a unique instead of the name
-bangVar :: Has (Uniques :+: Reader DynFlags) sig m => LExpr -> Loc -> m RdrName
-bangVar (L spn expr) loc = do
-  dflags <- ask
-  let name = '!' : case lines (showPpr dflags expr) of
-        (str:rest) | null rest && length str < 20 -> str
-                   | otherwise                    -> take 16 str ++ "..."
-        _                                         -> "<empty expression>"
-  locVar name (locA spn) loc
-
-locVar :: Has Uniques sig m => String -> SrcSpan -> Loc -> m RdrName
-locVar str spn loc = do
-  let occ = mkVarOcc $ printf "<%s:%d:%d>" str loc.line loc.col
-  unique <- freshUnique
-  pure . nameRdrName $ mkInternalName unique occ spn
-
-tellOne :: Has (Writer (DList w)) sig m => w -> m ()
-tellOne x = tell $ Endo (x:)
-
-tellLocalVar :: Has (Writer Occs) sig m => OccName -> m ()
-tellLocalVar = tell . unitOccs
+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}++module MonadicBang.Internal where++import Prelude hiding (log)+import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Identity+import Control.Carrier.Reader+import Control.Carrier.Writer.Strict+import Control.Carrier.State.Strict+import Control.Carrier.Throw.Either+import Control.Carrier.Lift+import Control.Effect.Sum hiding (L)+import Control.Exception hiding (try, handle, Handler)+import Data.Data+import Data.Foldable+import Data.Functor+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Monoid+import GHC hiding (Type)+import GHC.Data.Bag+import GHC.Data.Maybe+import GHC.Parser.Errors.Types+import GHC.Plugins hiding (Type, Expr, empty, (<>), panic, try)+import GHC.Types.Error+import GHC.Utils.Monad (concatMapM, whenM)+import Text.Printf++import GHC.Utils.Logger++import MonadicBang.Internal.Effect.Offer+import MonadicBang.Internal.Effect.Uniques+import MonadicBang.Internal.Options+import MonadicBang.Internal.Utils+import MonadicBang.Internal.Error+import MonadicBang.Internal.Effect.Writer.Discard++import Data.Kind+import Data.Coerce++-- We don't care about which file things are from, because the entire AST comes+-- from the same module+data Loc = MkLoc {line :: Int, col :: Int}+         deriving (Eq, Ord, Show)++type Expr = HsExpr GhcPs+type LExpr = LHsExpr GhcPs++-- | OccSet newtype that allows us to define an orphan Monoid instance+newtype Occs = MkOccs OccSet++instance Semigroup Occs where+  (<>) = coerce unionOccSets++instance Monoid Occs where+  mempty = emptyOccs++emptyOccs :: Occs+emptyOccs = coerce emptyOccSet++extendOccs :: Occs -> OccName -> Occs+extendOccs = coerce extendOccSet++elemOccs :: OccName -> Occs -> Bool+elemOccs = coerce elemOccSet++unitOccs :: OccName -> Occs+unitOccs = coerce unitOccSet++-- | To keep track of which local variables in scope may be used+--+-- If local variables are defined within the same statement as a !, but outside+-- of that !, they must not be used within this !, since their desugaring would+-- make them escape their scope.+data InScope = MkInScope {valid :: Occs , invalid :: Occs}++instance Semigroup InScope where+  a <> b = MkInScope{valid = a.valid <> b.valid, invalid = a.invalid <> b.invalid}++instance Monoid InScope where+  mempty = noneInScope++noneInScope :: InScope+noneInScope = MkInScope emptyOccs emptyOccs++addValid :: OccName -> InScope -> InScope+addValid name inScope = inScope{valid = extendOccs inScope.valid name}++addValids :: Occs -> InScope -> InScope+addValids names inScope = inScope{valid = inScope.valid <> names}++invalidateVars :: InScope -> InScope+invalidateVars inScope = MkInScope{valid = emptyOccs, invalid = inScope.valid <> inScope.invalid}++isInvalid :: Has (Reader InScope) sig m => OccName -> m Bool+isInvalid name = do+  inScope <- ask @InScope+  pure $ name `elemOccs` inScope.invalid++-- | Decrement column by one to get the location of a !+bangLoc :: Loc -> Loc+bangLoc loc = loc{col = loc.col - 1}++-- | Decrement start by one column to get the location of a !+bangSpan :: SrcSpan -> SrcSpan+bangSpan sp = mkSrcSpan (bangSrcLoc $ srcSpanStart sp) (srcSpanEnd sp)++-- | Decrement column by one to get the location of a !+bangSrcLoc :: SrcLoc -> SrcLoc+bangSrcLoc = \cases+  l@(UnhelpfulLoc _) -> l+  (RealSrcLoc srcLoc _) -> liftA3 mkSrcLoc srcLocFile srcLocLine (pred . srcLocCol) srcLoc++-- | Used to extract the Loc of a located expression+pattern ExprLoc :: Loc -> Expr -> LExpr+pattern ExprLoc loc expr <- L (locA -> RealSrcSpan (spanToLoc -> loc) _) expr++spanToLoc :: RealSrcSpan -> Loc+spanToLoc = liftA2 MkLoc srcLocLine srcLocCol . realSrcSpanStart++replaceBangs :: [CommandLineOption] -> ModSummary -> Handler Hsc ParsedResult+replaceBangs cmdLineOpts _ orig@(ParsedResult (HsParsedModule mod' files) msgs)+  | null fills = pure orig+  | otherwise = do+    options <- liftIO . (either throwIO pure =<<) . runThrow @ErrorCall $ parseOptions mod' cmdLineOpts+    dflags <- getDynFlags+    (newErrors, mod'') <-+      runM .+      runUniquesIO 'p' .+      runWriter .+      runReader options .+      runReader noneInScope .+      evalWriter @Occs .+      runReader dflags $+      fillHoles fills mod'+    log options.verbosity (ppr mod'')+    pure $ ParsedResult (HsParsedModule mod'' files) msgs{psErrors = oldErrors <> newErrors}+  where+    log = \cases+      Quiet _ -> pure ()+      DumpTransformed m -> do+        logger <- getLogger+        liftIO $ logMsg logger MCInfo (UnhelpfulSpan UnhelpfulNoLocationInfo) m++    -- Extract the errors we care about, throw the rest back in+    (mkMessages -> oldErrors, M.fromList . bagToList -> fills) =+      (partitionBagWith ?? msgs.psErrors.getMessages) \cases+        err | PsErrBangPatWithoutSpace lexpr@(ExprLoc (bangLoc -> loc) _) <- err.errMsgDiagnostic+            -> Right (loc, lexpr)+            | otherwise -> Left err+                  +type HandleFailure :: Bool -> (Type -> Type) -> (Type -> Type)+type family HandleFailure canFail = t | t -> canFail where+  HandleFailure True = MaybeT+  HandleFailure False = IdentityT++class MonadTrans t => HandlingMonadTrans t where+  toMaybeT :: Monad m => t m a -> MaybeT m a++instance HandlingMonadTrans IdentityT where+  toMaybeT = MaybeT . fmap Just . runIdentityT ++instance HandlingMonadTrans MaybeT where+  toMaybeT = id++class Typeable (AstType a) => Handle a where+  type CanFail a :: Bool+  type AstType a = (r :: Type) | r -> a+  type Effects a :: (Type -> Type) -> Type -> Type+  handle' :: forall sig m m' . m ~ HandleFailure (CanFail a) m' => Has (Effects a) sig m' => Handler m (AstType a)++handle :: forall a sig m . (Handle a, CanFail a ~ False) => Has (Effects a) sig m => Handler m (AstType a)+handle = runIdentityT . handle'++try :: forall e sig m a .+       (HandlingMonadTrans (HandleFailure (CanFail e)), Typeable a, Handle e, Monad m, Has (Effects e) sig m) =>+       Try m a+try x = do+  Refl <- hoistMaybe $ eqT @a @(AstType e)+  toMaybeT $ handle' x++instance Handle GRHSs where+  type CanFail GRHSs = False+  type AstType GRHSs = GRHSs GhcPs LExpr+  type Effects GRHSs = Fill+  handle' grhss = do+    patVars <- ask @InScope+    grhssLocalBinds <- local (<> patVars) $ evac grhss.grhssLocalBinds+    grhssGRHSs <- evalState patVars $ evacPats grhss.grhssGRHSs+    pure grhss{grhssGRHSs, grhssLocalBinds}++instance Handle MatchGroup where+  type CanFail MatchGroup = False+  type AstType MatchGroup = MatchGroup GhcPs LExpr+  type Effects MatchGroup = Fill+  handle' mg = do+    mg_alts <- (traverse . traverse . traverse) handle mg.mg_alts+    pure mg{mg_alts}++instance Handle Match where+  type CanFail Match = False+  type AstType Match = Match GhcPs LExpr+  type Effects Match = Fill+  handle' match = do+    -- We use the State to keep track of the bindings that have been+    -- introduced in patterns to the left of the one we're currently looking+    -- at. Example:+    --+    -- > \a (Just [b, (+ b) -> d]) (foldr a b -> c) | Just f <- b, f == 24+    --+    -- the view pattern on `c` has access to the variables to the left of it. The same applies to `d`.+    -- `f == 24` additionally has access to variables defined in the guard to its left.+    (patVars, m_pats) <- ask @InScope >>= runState ?? evacPats match.m_pats+    m_grhss <- local (<> patVars) $ handle match.m_grhss+    pure match{m_pats, m_grhss}++-- | We keep track of any local binds, to prevent the user from using them+-- with ! in situations where they would be evacuated to a place where+-- they're not in scope+--+-- The plugin would still work without this, but might accept programs that+-- shouldn't be accepted, with unexpected semantics. E.g:+--+-- > do let s = pure "outer"+-- >    let s = pure "inner" in putStrLn !s+--+-- You might expect this to print `inner`, but it would actually print+-- `outer`, since it would be desugared to+--+-- > do let s = pure "outer"+-- >    <!s> <- s+-- >    let s = pure "inner" in print <!s>+--+-- With this function, the plugin will instead throw an error saying that+-- `s` cannot be used here.+--+-- If the first `s` weren't defined, the user would, without this function,+-- get an error saying that `s` is not in scope, at the call site. Here,+-- we instead throw a more informative error.+--+-- If only the first `s` were defined, i.e.+--+-- > do let s = pure "outer"+-- >    putStrLn !s+--+-- it would be valid code.++instance Handle HsBindLR where+  type CanFail HsBindLR = True+  type AstType HsBindLR = HsBindLR GhcPs GhcPs+  type Effects HsBindLR = Fill+  handle' bind = case bind of+    FunBind{fun_id = occName . unLoc -> name, fun_matches = matches} -> do+      tellLocalVar name+      fun_matches <- local (addValid name) $ handle matches+      pure bind{fun_matches}+    PatBind{pat_lhs = lhs, pat_rhs = rhs} -> do+      (binds, pat_lhs) <- ask @InScope >>= flip runState (traverse evacPats lhs)+      pat_rhs <- local (<> binds) $ handle rhs+      pure bind{pat_lhs, pat_rhs}+    -- All VarBinds are introduced by the type checker, but we might as well handle them+    VarBind{var_id = occName -> name, var_rhs = expr} -> do+      tellLocalVar name+      var_rhs <- local (addValid name) $ evac expr+      pure bind{var_rhs}+    -- Pattern synonyms can never appear inside of do blocks, so we don't have+    -- to handle them specially+    PatSynBind{} -> empty++instance Handle Pat where+  type CanFail Pat = True+  type AstType Pat = Pat GhcPs+  type Effects Pat = Fill :+: State InScope+  handle' = \case+    VarPat xv name -> tellName name $> VarPat xv name+#if MIN_VERSION_ghc(9,10,0)+    AsPat xa name pat -> do+      tellName name+      AsPat xa name <$> traverse (liftMaybeT . evacPats) pat+#elif MIN_VERSION_ghc(9,6,0)+    AsPat xa name tok pat -> do+      tellName name+      AsPat xa name tok <$> traverse (liftMaybeT . evacPats) pat+#else+    AsPat xa name pat -> do+      tellName name+      AsPat xa name <$> traverse (liftMaybeT . evacPats) pat+#endif++    _ -> empty+    where+      tellName (occName . unLoc -> name) = do+        tellLocalVar name+        modify $ addValid name++instance Handle HsExpr where+  type CanFail HsExpr = True+  type AstType HsExpr = GenLocated SrcSpanAnnA Expr+  type Effects HsExpr = Fill+  handle' e@(L l _) = do+    ExprLoc loc expr <- pure e+    case expr of+      -- Replace holes resulting from `!`+      -- If no corresponding expression can be found in the Offer, we assume+      -- that it was a hole put there by the user and leave it unmodified+#if MIN_VERSION_ghc(9,14,0)+      HsHole _ -> yoink loc >>= maybe (pure e) \lexpr -> do+#else+      HsUnboundVar _ _ -> yoink loc >>= maybe (pure e) \lexpr -> do+#endif+        -- all existing valid local variables now become invalid, since using+        -- them would make them escape their scope+        lexpr' <- local invalidateVars $ evac lexpr+        name <- bangVar lexpr' loc+        tellOne $ name :<- lexpr'+        pure . L l $ HsVar noExtField (noLocA name)+      HsVar _ (occName . unLoc -> name) -> do+        whenM (isInvalid name) do tellPsError (customError $ ErrOutOfScopeVariable name) (locA l)+        pure e+      -- In HsDo, we can discard all in-scope variables in the context, since+      -- any !-desugaring we encounter cannot escape outside of this+      -- 'do'-block, and thus also not outside of the scope of those+      -- variables+      HsDo xd ctxt stmts -> L l . HsDo xd ctxt <$> local (const noneInScope) (traverse addStmts stmts)+#if MIN_VERSION_ghc(9,10,0)+      HsLet xl binds ex -> do+        (boundVars, binds') <- runWriter @Occs $ evac binds+        fmap (L l . HsLet xl binds') <$> liftMaybeT . local (addValids boundVars) $ evac ex+#else+      HsLet xl letTok binds inTok ex -> do+        (boundVars, binds') <- runWriter @Occs $ evac binds+        fmap (L l . HsLet xl letTok binds' inTok) <$> liftMaybeT . local (addValids boundVars) $ evac ex+#endif++      _ -> empty++instance Handle StmtLR where+  type CanFail StmtLR = True+  type AstType StmtLR = StmtLR GhcPs GhcPs LExpr+  type Effects StmtLR = Fill+  handle' :: forall sig m m' . (m ~ MaybeT m', Has (Effects StmtLR) sig m') => Handler m (AstType StmtLR)+  handle' e = case e of++    RecStmt{recS_stmts} -> do+      recS_stmts' <- traverse addStmts recS_stmts+      pure e{recS_stmts = recS_stmts'}+    ParStmt xp stmtBlocks zipper bind -> do+      stmtsBlocks' <- traverse addParStmts stmtBlocks+      pure $ ParStmt xp stmtsBlocks' zipper bind+      where+        addParStmts :: Handler m (ParStmtBlock GhcPs GhcPs)+        addParStmts (ParStmtBlock xb stmts vars ret) = do+          stmts' <- addStmts stmts+          pure $ ParStmtBlock xb stmts' vars ret++    _ -> empty++-- | Replace holes in an AST whenever an expression with the corresponding+-- source span can be found in the given list.+fillHoles :: (Data a, Has (PsErrors :+: Reader Options :+: Uniques :+: LocalVars :+: Reader DynFlags) sig m) => Map Loc LExpr -> Handler m a+fillHoles fillers ast = do+  (remainingErrs, (fromDList -> (binds :: [BindStmt]), ast')) <- runOffer fillers . runWriter $ evac ast+  MkOptions{preserveErrors} <- ask+  for_ binds \bind -> tellPsError (psError (bindStmtExpr bind) preserveErrors) (bangSpan $ bindStmtSpan bind)+  dflags <- ask+  pure if null remainingErrs+    then ast'+    else panic $ unlines $ "Found extraneous bangs:" : (showPpr dflags <$> toList remainingErrs)+  where+    psError expr = \cases+      Preserve      -> PsErrBangPatWithoutSpace expr+      Don'tPreserve -> customError ErrBangOutsideOfDo++evac :: forall a sig m . (Has Fill sig m, Data a) => Handler m a+-- This recurses over all nodes in the AST, except for nodes for which+-- one of the `try` functions returns `Just <something>`.+evac e = maybe (gmapM evac e) pure =<< runMaybeT (tryEvac usualTries e)++tryEvac :: Monad m => [Try m a] -> Try m a+tryEvac tries = asum . (tries ??)++usualTries :: (Has Fill sig m, Data a) => [Try m a]+usualTries =+  [ try @HsExpr, try @HsBindLR, try @MatchGroup, try @StmtLR+  , ignore @RdrName, ignore @OccName, ignore @RealSrcSpan, ignore @EpAnnComments+  ]++-- As a minor performance optimization, we don't recurse over the AST if the node+-- is a type that we know will never contain an expression+ignore :: forall (e :: Type) m a . (Monad m, Typeable a, Typeable e) => Try m a+ignore e = do+  Refl <- hoistMaybe $ eqT @e @a+  pure e++-- | evacuate !s in pattern and collect all the names it binds+evacPats :: forall a m sig . (Has (Fill :+: State InScope) sig m, Data a) => Handler m a+evacPats e = do+  currentState <- get @InScope+  maybe (gmapM evacPats e) pure =<< runMaybeT (tryEvac ((local (<> currentState) .) <$> (try @Pat : usualTries)) e)++-- | Find all !s in the given statements and combine the resulting bind+-- statements into lists, with the original statements being the last one+-- in each list - then concatenate these lists+addStmts :: forall sig m . Has (PsErrors :+: HoleFills :+: Uniques :+: LocalVars :+: Reader DynFlags) sig m => Handler m [ExprLStmt GhcPs]+addStmts = concatMapM \lstmt -> do+  (fromDList -> stmts, lstmt') <- runWriter $ evac lstmt+  pure $ map fromBindStmt stmts ++ [lstmt']++type HoleFills = Offer Loc LExpr+-- | We keep track of variables that are bound in lambdas, cases, etc., since+-- these are variables that will not be accessible in the surrounding+-- 'do'-block, and must therefore not be used.+-- The Reader is used to find out what local variables are in scope, the Writer+-- is used to inform callers which local variables have been bound.+type LocalVars = Reader InScope :+: Writer Occs++type Fill = PsErrors :+: Writer (DList BindStmt) :+: HoleFills :+: Uniques :+: LocalVars :+: Reader DynFlags++data BindStmt = RdrName :<- LExpr++bindStmtExpr :: BindStmt -> LExpr+bindStmtExpr (_ :<- expr) = expr++bindStmtSpan :: BindStmt -> SrcSpan+bindStmtSpan = locA . \(_ :<- L l _) -> l++fromBindStmt :: BindStmt -> ExprLStmt GhcPs+fromBindStmt = noLocA . \cases+  (var :<- lexpr) -> BindStmt noAnn varPat lexpr+    where+      varPat = noLocA . VarPat noExtField $ noLocA var++-- | Use the !'d expression if it's short enough, or else abbreviate with `...`+-- We don't need to worry about shadowing other !'d expressions:+-- - For the user, we add line and column numbers to the name+-- - For the compiler, we use a unique instead of the name+bangVar :: Has (Uniques :+: Reader DynFlags) sig m => LExpr -> Loc -> m RdrName+bangVar (L spn expr) loc = do+  dflags <- ask+  let name = '!' : case lines (showPpr dflags expr) of+        (str:rest) | null rest && length str < 20 -> str+                   | otherwise                    -> take 16 str ++ "..."+        _                                         -> "<empty expression>"+  locVar name (locA spn) loc++locVar :: Has Uniques sig m => String -> SrcSpan -> Loc -> m RdrName+locVar str spn loc = do+  let occ = mkVarOcc $ printf "<%s:%d:%d>" str loc.line loc.col+  unique <- freshUnique+  pure . nameRdrName $ mkInternalName unique occ spn++tellOne :: Has (Writer (DList w)) sig m => w -> m ()+tellOne x = tell $ Endo (x:)++tellLocalVar :: Has (Writer Occs) sig m => OccName -> m ()+tellLocalVar = tell . unitOccs

@@ -1,35 +1,35 @@-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE MonoLocalBinds #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-
-module MonadicBang.Internal.Effect.Offer where
-
-import Control.Algebra
-import Control.Carrier.State.Strict
-import Data.Map.Strict (Map)
-import Data.Map.Strict qualified as M
-
--- | Offers a number of things that can be yoinked, but only once
-data Offer k v m a where
-  Yoink :: k -> Offer k v m (Maybe v)
-
-yoink :: Has (Offer k v) sig m => k -> m (Maybe v)
-yoink = send . Yoink
-
-newtype OfferC k v m a = OfferC {getOfferState :: StateC (Map k v) m a}
-  deriving newtype (Functor, Applicative, Monad)
-
--- Returns the result of the computation, along with the remaining offers
-runOffer :: Map k v -> OfferC k v m a -> m (Map k v, a)
-runOffer o (OfferC s) = runState o s
-
-instance (Algebra sig m, Ord k) => Algebra (Offer k v :+: sig) (OfferC k v m) where
-  alg hdl sig ctx = case sig of
-    L (Yoink k) -> OfferC do
-      (mv, remaining) <- M.updateLookupWithKey (\_ _ -> Nothing) k <$> get
-      put remaining
-      pure (mv <$ ctx)
-    R other -> OfferC (alg ((.getOfferState) . hdl) (R other) ctx)
-  {-# INLINE alg #-}
+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedRecordDot #-}++module MonadicBang.Internal.Effect.Offer where++import Control.Algebra+import Control.Carrier.State.Strict+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M++-- | Offers a number of things that can be yoinked, but only once+data Offer k v m a where+  Yoink :: k -> Offer k v m (Maybe v)++yoink :: Has (Offer k v) sig m => k -> m (Maybe v)+yoink = send . Yoink++newtype OfferC k v m a = OfferC {getOfferState :: StateC (Map k v) m a}+  deriving newtype (Functor, Applicative, Monad)++-- Returns the result of the computation, along with the remaining offers+runOffer :: Map k v -> OfferC k v m a -> m (Map k v, a)+runOffer o (OfferC s) = runState o s++instance (Algebra sig m, Ord k) => Algebra (Offer k v :+: sig) (OfferC k v m) where+  alg hdl sig ctx = case sig of+    L (Yoink k) -> OfferC do+      (mv, remaining) <- M.updateLookupWithKey (\_ _ -> Nothing) k <$> get+      put remaining+      pure (mv <$ ctx)+    R other -> OfferC (alg ((.getOfferState) . hdl) (R other) ctx)+  {-# INLINE alg #-}

@@ -1,41 +1,41 @@-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE MonoLocalBinds #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-
-module MonadicBang.Internal.Effect.Uniques where
-
-import Control.Algebra
-import Control.Carrier.State.Strict
-import Control.Monad.IO.Class
-import Data.Functor
-import Data.Tuple
-
-import GHC.Types.Unique
-import GHC.Types.Unique.Supply
-
--- | Uniques provides arbitrarily many unique GHC Uniques
-data Uniques m a where
-  FreshUnique :: Uniques m Unique
-
-freshUnique :: Has Uniques sig m => m Unique
-freshUnique = send FreshUnique
-
-newtype UniquesC m a = UniquesC {getUniquesState :: StateC UniqSupply m a}
-  deriving newtype (Functor, Applicative, Monad)
-
--- | The "mask" (Char) supplied is purely cosmetic, making it easier to figure out where a Unique was born.
---
--- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques
-runUniquesIO :: MonadIO m => Char -> UniquesC m a -> m a
-runUniquesIO mask (UniquesC s) = flip evalState s =<< liftIO (mkSplitUniqSupply mask)
-
-runUniques :: Functor m => UniqSupply -> UniquesC m a -> m a
-runUniques uniqSupply (UniquesC s) = evalState uniqSupply s
-
-instance Algebra sig m => Algebra (Uniques :+: sig) (UniquesC m) where
-  alg hdl sig ctx = case sig of
-    L FreshUnique -> UniquesC . state $ fmap (ctx $>) . swap . takeUniqFromSupply
-    R other -> UniquesC (alg ((.getUniquesState) . hdl) (R other) ctx)
-  {-# INLINE alg #-} 
+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedRecordDot #-}++module MonadicBang.Internal.Effect.Uniques where++import Control.Algebra+import Control.Carrier.State.Strict+import Control.Monad.IO.Class+import Data.Functor+import Data.Tuple++import GHC.Types.Unique+import GHC.Types.Unique.Supply++-- | Uniques provides arbitrarily many unique GHC Uniques+data Uniques m a where+  FreshUnique :: Uniques m Unique++freshUnique :: Has Uniques sig m => m Unique+freshUnique = send FreshUnique++newtype UniquesC m a = UniquesC {getUniquesState :: StateC UniqSupply m a}+  deriving newtype (Functor, Applicative, Monad)++-- | The "mask" (Char) supplied is purely cosmetic, making it easier to figure out where a Unique was born.+--+-- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques+runUniquesIO :: MonadIO m => Char -> UniquesC m a -> m a+runUniquesIO mask (UniquesC s) = flip evalState s =<< liftIO (mkSplitUniqSupply mask)++runUniques :: Functor m => UniqSupply -> UniquesC m a -> m a+runUniques uniqSupply (UniquesC s) = evalState uniqSupply s++instance Algebra sig m => Algebra (Uniques :+: sig) (UniquesC m) where+  alg hdl sig ctx = case sig of+    L FreshUnique -> UniquesC . state $ fmap (ctx $>) . swap . takeUniqFromSupply+    R other -> UniquesC (alg ((.getUniquesState) . hdl) (R other) ctx)+  {-# INLINE alg #-} 

@@ -1,24 +1,24 @@-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE GADTs #-}
-
--- | A Writer carrier that discards any values it is told
-module MonadicBang.Internal.Effect.Writer.Discard where
-
-import Control.Algebra
-import Control.Effect.Writer
-
-newtype DiscardC w m a = DiscardC { evalDiscardC :: m a }
-  deriving newtype (Functor, Applicative, Monad)
-
-evalWriter :: (Monoid w, Algebra sig m) => DiscardC w m a -> m a
-evalWriter = evalDiscardC
-
-instance (Monoid w, Algebra sig m) => Algebra (Writer w :+: sig) (DiscardC w m) where
-  alg hdl sig ctx = DiscardC $ case sig of
-    L writer -> case writer of
-      Tell _ -> pure ctx
-      Listen m -> fmap (mempty,) <$> evalWriter (hdl (m <$ ctx))
-      Censor _ m -> evalWriter (hdl (m <$ ctx))
-    R other -> alg (evalDiscardC . hdl) other ctx
+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE GADTs #-}++-- | A Writer carrier that discards any values it is told+module MonadicBang.Internal.Effect.Writer.Discard where++import Control.Algebra+import Control.Effect.Writer++newtype DiscardC w m a = DiscardC { evalDiscardC :: m a }+  deriving newtype (Functor, Applicative, Monad)++evalWriter :: (Monoid w, Algebra sig m) => DiscardC w m a -> m a+evalWriter = evalDiscardC++instance (Monoid w, Algebra sig m) => Algebra (Writer w :+: sig) (DiscardC w m) where+  alg hdl sig ctx = DiscardC $ case sig of+    L writer -> case writer of+      Tell _ -> pure ctx+      Listen m -> fmap (mempty,) <$> evalWriter (hdl (m <$ ctx))+      Censor _ m -> evalWriter (hdl (m <$ ctx))+    R other -> alg (evalDiscardC . hdl) other ctx

@@ -1,49 +1,49 @@-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE CPP #-}
-
-module MonadicBang.Internal.Error where
-
-import Prelude hiding ((<>))
-
-import Control.Effect.Writer
-
-import GHC
-#if MIN_VERSION_ghc(9,8,0)
-import GHC.Utils.Error
-#endif
-import GHC.Types.Error
-import GHC.Types.Name.Occurrence
-import GHC.Parser.Errors.Types
-import GHC.Utils.Outputable
-
-data Error = ErrOutOfScopeVariable OccName
-           | ErrBangOutsideOfDo
-
-type PsErrors = Writer (Messages PsError)
-
-customError :: Error -> PsError
-#if MIN_VERSION_ghc(9,8,0)
-customError = PsUnknownMessage . mkUnknownDiagnostic . \cases
-#elif MIN_VERSION_ghc(9,6,0)
-customError = PsUnknownMessage . UnknownDiagnostic . \cases
-#else
-customError = PsUnknownMessage . \cases
-#endif
-  ErrBangOutsideOfDo -> DiagnosticMessage
-    { diagMessage = mkDecorated [text "Monadic ! outside of a 'do'-block is not allowed"]
-    , diagReason = ErrorWithoutFlag
-    , diagHints = [SuggestMissingDo]
-    }
-  (ErrOutOfScopeVariable name) -> DiagnosticMessage
-    { diagMessage = mkDecorated [text "The variable " <> quotes (ppr name) <> text " cannot be used inside of ! here, since its desugaring would escape its scope"]
-    , diagReason = ErrorWithoutFlag
-    , diagHints = [UnknownHint $ text "Maybe you meant to open a new 'do'-block after " <> ppr name <> text " has been bound?"]
-    }
-
-tellPsError :: Has PsErrors sig m => PsError -> SrcSpan -> m ()
-tellPsError err srcSpan = tell . singleMessage $
-#if MIN_VERSION_ghc(9,8,0)
-  mkErrorMsgEnvelope srcSpan neverQualify err
-#else
-  MsgEnvelope srcSpan neverQualify err SevError
-#endif
+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}++module MonadicBang.Internal.Error where++import Prelude hiding ((<>))++import Control.Effect.Writer++import GHC+#if MIN_VERSION_ghc(9,8,0)+import GHC.Utils.Error+#endif+import GHC.Types.Error+import GHC.Types.Name.Occurrence+import GHC.Parser.Errors.Types+import GHC.Utils.Outputable++data Error = ErrOutOfScopeVariable OccName+           | ErrBangOutsideOfDo++type PsErrors = Writer (Messages PsError)++customError :: Error -> PsError+#if MIN_VERSION_ghc(9,8,0)+customError = PsUnknownMessage . mkUnknownDiagnostic . \cases+#elif MIN_VERSION_ghc(9,6,0)+customError = PsUnknownMessage . UnknownDiagnostic . \cases+#else+customError = PsUnknownMessage . \cases+#endif+  ErrBangOutsideOfDo -> DiagnosticMessage+    { diagMessage = mkDecorated [text "Monadic ! outside of a 'do'-block is not allowed"]+    , diagReason = ErrorWithoutFlag+    , diagHints = [SuggestMissingDo]+    }+  (ErrOutOfScopeVariable name) -> DiagnosticMessage+    { diagMessage = mkDecorated [text "The variable " <> quotes (ppr name) <> text " cannot be used inside of ! here, since its desugaring would escape its scope"]+    , diagReason = ErrorWithoutFlag+    , diagHints = [UnknownHint $ text "Maybe you meant to open a new 'do'-block after " <> ppr name <> text " has been bound?"]+    }++tellPsError :: Has PsErrors sig m => PsError -> SrcSpan -> m ()+tellPsError err srcSpan = tell . singleMessage $+#if MIN_VERSION_ghc(9,8,0)+  mkErrorMsgEnvelope srcSpan neverQualify err+#else+  MsgEnvelope srcSpan neverQualify err SevError+#endif

@@ -1,61 +1,61 @@-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE CPP #-}
-
-module MonadicBang.Internal.Options where
-
-import Control.Exception
-import Control.Algebra
-import Control.Carrier.State.Strict
-import Control.Effect.Throw
-import Control.Monad
-import Data.Bifunctor
-import Data.Bool
-import Data.List (intercalate, partition)
-
-import GHC
-import GHC.Plugins
-
-data Verbosity = DumpTransformed | Quiet
-
-data PreserveErrors = Preserve | Don'tPreserve
-
-data Options = MkOptions {verbosity :: Verbosity, preserveErrors :: PreserveErrors}
-
-#if MIN_VERSION_ghc(9,6,0)
-parseOptions :: Has (Throw ErrorCall) sig m => Located (HsModule GhcPs) -> [CommandLineOption] -> m Options
-#else
-parseOptions :: Has (Throw ErrorCall) sig m => Located HsModule -> [CommandLineOption] -> m Options
-#endif
-parseOptions mod' cmdLineOpts = do
-  (remaining, options) <- runState cmdLineOpts do
-    verbosity <- bool Quiet DumpTransformed <$> extractOpts verboseOpts
-    preserveErrors <- bool Don'tPreserve Preserve <$> extractOpts preserveErrorsOpts
-    pure $ MkOptions verbosity preserveErrors
-  unless (null remaining) . throwError . ErrorCall $
-    "Incorrect command line options for plugin MonadicBang, encountered in " ++ modName ++ modFile ++
-    "\n\tOptions that were supplied (via -fplugin-opt) are: " ++ intercalate ", " (map show cmdLineOpts) ++
-    "\n\tUnrecognized options: " ++ showOpts remaining ++
-    "\n\n\tUsage: [-ddump] [-preserve-errors]" ++
-    "\n" ++
-    "\n\t\t-ddump            Print the altered AST" ++
-    "\n\t\t-preserve-errors  Keep parse errors about ! outside of 'do' in their original form, rather then a more relevant explanation." ++
-    "\n\t\t                  This is mainly useful if another plugin expects those errors."
-  pure options
-
-  where
-    verboseOpts = ["-ddump"]
-    preserveErrorsOpts = ["-preserve-errors"]
-    extractOpts opt = do
-      (isOpt, opts') <- gets $ first (not . null) . partition (`elem` opt)
-      put opts'
-      pure isOpt
-
-    showOpts = intercalate ", " . map show
-
-    modFile = maybe "" ((" in file " ++) . unpackFS . srcSpanFile) $ toRealSrcSpan (getLoc mod')
-    modName = maybe "an unnamed module" (("module " ++) . moduleNameString . unLoc) $ (unLoc mod').hsmodName
-    toRealSrcSpan = \cases
-      (RealSrcSpan rss _) -> Just rss
-      (UnhelpfulSpan _) -> Nothing
+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE CPP #-}++module MonadicBang.Internal.Options where++import Control.Exception+import Control.Algebra+import Control.Carrier.State.Strict+import Control.Effect.Throw+import Control.Monad+import Data.Bifunctor+import Data.Bool+import Data.List (intercalate, partition)++import GHC+import GHC.Plugins++data Verbosity = DumpTransformed | Quiet++data PreserveErrors = Preserve | Don'tPreserve++data Options = MkOptions {verbosity :: Verbosity, preserveErrors :: PreserveErrors}++#if MIN_VERSION_ghc(9,6,0)+parseOptions :: Has (Throw ErrorCall) sig m => Located (HsModule GhcPs) -> [CommandLineOption] -> m Options+#else+parseOptions :: Has (Throw ErrorCall) sig m => Located HsModule -> [CommandLineOption] -> m Options+#endif+parseOptions mod' cmdLineOpts = do+  (remaining, options) <- runState cmdLineOpts do+    verbosity <- bool Quiet DumpTransformed <$> extractOpts verboseOpts+    preserveErrors <- bool Don'tPreserve Preserve <$> extractOpts preserveErrorsOpts+    pure $ MkOptions verbosity preserveErrors+  unless (null remaining) . throwError . ErrorCall $+    "Incorrect command line options for plugin MonadicBang, encountered in " ++ modName ++ modFile +++    "\n\tOptions that were supplied (via -fplugin-opt) are: " ++ intercalate ", " (map show cmdLineOpts) +++    "\n\tUnrecognized options: " ++ showOpts remaining +++    "\n\n\tUsage: [-ddump] [-preserve-errors]" +++    "\n" +++    "\n\t\t-ddump            Print the altered AST" +++    "\n\t\t-preserve-errors  Keep parse errors about ! outside of 'do' in their original form, rather then a more relevant explanation." +++    "\n\t\t                  This is mainly useful if another plugin expects those errors."+  pure options++  where+    verboseOpts = ["-ddump"]+    preserveErrorsOpts = ["-preserve-errors"]+    extractOpts opt = do+      (isOpt, opts') <- gets $ first (not . null) . partition (`elem` opt)+      put opts'+      pure isOpt++    showOpts = intercalate ", " . map show++    modFile = maybe "" ((" in file " ++) . unpackFS . srcSpanFile) $ toRealSrcSpan (getLoc mod')+    modName = maybe "an unnamed module" (("module " ++) . moduleNameString . unLoc) $ (unLoc mod').hsmodName+    toRealSrcSpan = \cases+      (RealSrcSpan rss _) -> Just rss+      (UnhelpfulSpan _) -> Nothing

@@ -1,38 +1,38 @@-{-# LANGUAGE MonoLocalBinds #-}
-{-# LANGUAGE CPP #-}
-
-module MonadicBang.Internal.Utils where
-
-import Control.Monad.Trans.Maybe
-import Data.Monoid
-import GHC.Stack (withFrozenCallStack, HasCallStack)
-
-type DList a = Endo [a]
-
--- | Handle a specific AST node
-type Handler m a = a -> m a
-
--- | Try handling an AST node, but may fail (usually because the handler is not
--- applicable)
-type Try m a = Handler (MaybeT m) a
-
-{-# INLINE fromDList #-}
-fromDList :: DList a -> [a]
-fromDList = appEndo ?? []
-
-{-# INLINE (??) #-}
-(??) :: Functor f => f (a -> b) -> a -> f b
-fs ?? x = ($ x) <$> fs
-
-#if MIN_VERSION_transformers(0,6,0)
-#else
-{-# INLINE hoistMaybe #-}
-hoistMaybe :: Applicative m => Maybe a -> MaybeT m a
-hoistMaybe = MaybeT . pure
-#endif
-
-panic :: HasCallStack => String -> a
-panic message = withFrozenCallStack $ error $
-  unlines ["MonadicBang panic:", message, "", submitReport]
-  where
-    submitReport = "This is likely a bug. Please submit a bug report at https://github.com/JakobBruenker/monadic-bang/issues"
+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE CPP #-}++module MonadicBang.Internal.Utils where++import Control.Monad.Trans.Maybe+import Data.Monoid+import GHC.Stack (withFrozenCallStack, HasCallStack)++type DList a = Endo [a]++-- | Handle a specific AST node+type Handler m a = a -> m a++-- | Try handling an AST node, but may fail (usually because the handler is not+-- applicable)+type Try m a = Handler (MaybeT m) a++{-# INLINE fromDList #-}+fromDList :: DList a -> [a]+fromDList = appEndo ?? []++{-# INLINE (??) #-}+(??) :: Functor f => f (a -> b) -> a -> f b+fs ?? x = ($ x) <$> fs++#if MIN_VERSION_transformers(0,6,0)+#else+{-# INLINE hoistMaybe #-}+hoistMaybe :: Applicative m => Maybe a -> MaybeT m a+hoistMaybe = MaybeT . pure+#endif++panic :: HasCallStack => String -> a+panic message = withFrozenCallStack $ error $+  unlines ["MonadicBang panic:", message, "", submitReport]+  where+    submitReport = "This is likely a bug. Please submit a bug report at https://github.com/JakobBruenker/monadic-bang/issues"

@@ -1,51 +1,51 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE LexicalNegation #-}
-{-# LANGUAGE MonadComprehensions #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module Main (main) where
-
-import Prelude hiding ((<>))
-#if MIN_VERSION_ghc(9,6,0)
-#else
-import Control.Applicative (liftA2)
-#endif
-import Data.Foldable
-import Data.Traversable
-import System.IO
-
-import MonadicBang.Test.Utils
-import MonadicBang.Test.ShouldPass
-import MonadicBang.Test.ShouldFail
-
-import GHC.Utils.Outputable
-import GHC.Utils.Ppr (Mode(PageMode))
-import System.Exit (exitFailure)
-
-main :: IO ()
-main = do
-  (numFailures, numFailedSuites) <- liftA2 (,) sum (length . filter (> 0)) <$> for suites \suite -> do
-    failures <- runSuite suite
-    for_ failures \failure -> putSDoc stderr $ vcat [space, prettyFail failure]
-    pure $ length failures
-  if numFailures == 0
-    then putStrLn "All tests passed!"
-    else do
-      putSDoc stdout $
-        space $+$ plural' numFailures "test" <+> text "in" <+> int numFailedSuites <> char '/' <> plural' (length suites) "suite" <+> text "failed."
-      exitFailure
-  where
-    plural' :: Int -> String -> SDoc
-    plural' n (text -> s) = int n <+> case n of
-      1 -> s
-      _ -> s <> char 's'
-
-putSDoc :: Handle -> SDoc -> IO ()
-putSDoc = printSDocLn defaultSDocContext (PageMode True)
-
-suites :: [TestType]
-suites =
-  [ shouldPass
-  , shouldFail
-  ]
+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LexicalNegation #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE ViewPatterns #-}++module Main (main) where++import Prelude hiding ((<>))+#if MIN_VERSION_ghc(9,6,0)+#else+import Control.Applicative (liftA2)+#endif+import Data.Foldable+import Data.Traversable+import System.IO++import MonadicBang.Test.Utils+import MonadicBang.Test.ShouldPass+import MonadicBang.Test.ShouldFail++import GHC.Utils.Outputable+import GHC.Utils.Ppr (Mode(PageMode))+import System.Exit (exitFailure)++main :: IO ()+main = do+  (numFailures, numFailedSuites) <- liftA2 (,) sum (length . filter (> 0)) <$> for suites \suite -> do+    failures <- runSuite suite+    for_ failures \failure -> putSDoc stderr $ vcat [space, prettyFail failure]+    pure $ length failures+  if numFailures == 0+    then putStrLn "All tests passed!"+    else do+      putSDoc stdout $+        space $+$ plural' numFailures "test" <+> text "in" <+> int numFailedSuites <> char '/' <> plural' (length suites) "suite" <+> text "failed."+      exitFailure+  where+    plural' :: Int -> String -> SDoc+    plural' n (text -> s) = int n <+> case n of+      1 -> s+      _ -> s <> char 's'++putSDoc :: Handle -> SDoc -> IO ()+putSDoc = printSDocLn defaultSDocContext (PageMode True)++suites :: [TestType]+suites =+  [ shouldPass+  , shouldFail+  ]

@@ -1,64 +1,64 @@-{-# LANGUAGE LambdaCase #-}
-
-module MonadicBang.Test.ShouldFail (shouldFail) where
-
-import MonadicBang.Test.Utils
-import MonadicBang.Internal.Error
-
-import GHC.Types.Name.Occurrence
-
-import GHC.Parser.Errors.Types
-
-shouldFail :: Test
-shouldFail = do
-  combined
-  various
-  letStmt
-  letInLet
-
-data ErrorData
-  = S String -- ^ Out of scope variable
-  | O        -- ^ Bang outside of do
-
-mkErrors :: [ErrorData] -> [PsMessage]
-mkErrors = map (customError . toError)
-  where
-    toError = \cases
-      (S var) -> ErrOutOfScopeVariable $ mkVarOcc var
-      O -> ErrBangOutsideOfDo
-
-combined :: Test
-combined = assertParseFailWith (mkErrors [S "x", S "f", S "a", S "b", S "b", O, O]) "\
-\!(!do\n\
-\  x <- getA\n\
-\  let y = let x = print 24 in !x\n\
-\  let f (a, b) = !(f a) + !(let c = c + b in c + b + z)\n\
-\  pure y)\n\
-\"
-
-various :: Test
-various = assertParseFailWith (mkErrors [S "a", S "x", S "y", S "b", S "b1", S "a2", O, O, O]) "\
-\main = !getA\n\
-\g = do let a = x in !a\n\
-\       pure ()\n\
-\f = !getB\n\
-\h = \\x -> !x\n\
-\i = do \\y -> !y\n\
-\j = let z = z in do \\_ -> !z -- no error\n\
-\k = case () of a -> do case () of b -> !(a + b)\n\
-\l = let c1 = c1 in do let b1 = b1 in !(let c1 = c1 in a1 + b1 + c1)\n\
-\m = do !(let a2 = a2 in !a2)\n\
-\"
-
-letStmt :: Test
-letStmt = assertParseFailWith (mkErrors [S "x"]) "\
-\main = do\n\
-\  let x = !x\n\
-\  pure x\n\
-\"
-
-letInLet :: Test
-letInLet = assertParseFailWith (mkErrors [S "y", S "x"]) "\
-\main = do\n\
-\  let x _ = x in let y = y in !y + !x\n\
-\"
+{-# LANGUAGE LambdaCase #-}++module MonadicBang.Test.ShouldFail (shouldFail) where++import MonadicBang.Test.Utils+import MonadicBang.Internal.Error++import GHC.Types.Name.Occurrence++import GHC.Parser.Errors.Types++shouldFail :: Test+shouldFail = do+  combined+  various+  letStmt+  letInLet++data ErrorData+  = S String -- ^ Out of scope variable+  | O        -- ^ Bang outside of do++mkErrors :: [ErrorData] -> [PsMessage]+mkErrors = map (customError . toError)+  where+    toError = \cases+      (S var) -> ErrOutOfScopeVariable $ mkVarOcc var+      O -> ErrBangOutsideOfDo++combined :: Test+combined = assertParseFailWith (mkErrors [S "x", S "f", S "a", S "b", S "b", O, O]) "\+\!(!do\n\+\  x <- getA\n\+\  let y = let x = print 24 in !x\n\+\  let f (a, b) = !(f a) + !(let c = c + b in c + b + z)\n\+\  pure y)\n\+\"++various :: Test+various = assertParseFailWith (mkErrors [S "a", S "x", S "y", S "b", S "b1", S "a2", O, O, O]) "\+\main = !getA\n\+\g = do let a = x in !a\n\+\       pure ()\n\+\f = !getB\n\+\h = \\x -> !x\n\+\i = do \\y -> !y\n\+\j = let z = z in do \\_ -> !z -- no error\n\+\k = case () of a -> do case () of b -> !(a + b)\n\+\l = let c1 = c1 in do let b1 = b1 in !(let c1 = c1 in a1 + b1 + c1)\n\+\m = do !(let a2 = a2 in !a2)\n\+\"++letStmt :: Test+letStmt = assertParseFailWith (mkErrors [S "x"]) "\+\main = do\n\+\  let x = !x\n\+\  pure x\n\+\"++letInLet :: Test+letInLet = assertParseFailWith (mkErrors [S "y", S "x"]) "\+\main = do\n\+\  let x _ = x in let y = y in !y + !x\n\+\"

@@ -1,153 +1,153 @@-{-# LANGUAGE RecursiveDo #-}
-{-# LANGUAGE QualifiedDo #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ParallelListComp #-}
-{-# LANGUAGE MonadComprehensions #-}
-{-# LANGUAGE NegativeLiterals #-}
-
-{-# OPTIONS_GHC -fplugin=MonadicBang #-}
-
-module MonadicBang.Test.ShouldPass where
- 
-import Data.Char
-import Control.Monad.Trans.State
-
-import MonadicBang.Test.Utils
-import MonadicBang.Test.Utils.QualifiedDo qualified as QualifiedDo
-import Control.Monad.IO.Class
-
-shouldPass :: Test
-shouldPass = do
-  simpleDo
-  insideDo
-  insideMDo
-  insideRec
-  nested
-  lambda
-  insideLet
-  listComp
-  monadComp
-  parListComp
-  multiWayIf
-  guards
-  viewPat
-  insideWhere
-  insideCase
-  usingDoBlockVar
-  largeExpr
-  confusing
-  qualifiedDo
-
-getA, getB, getC :: MonadIO m => m String
-getA = pure "a"
-getB = pure "b"
-getC = pure "c"
-
-simpleDo :: Test
-simpleDo = do assertEq "a" !getA
-
-insideDo :: Test
-insideDo = do
-  let ioA = getA
-      nonIOC = !getC
-  assertEq "abc" (!ioA ++ !ioB ++ nonIOC)
-  where
-    ioB = getB
-
-insideMDo :: Test
-insideMDo = assertEq (Just $ replicate @Int 10 -1) $ take 10 <$> mdo
-  xs <- Just (1:xs)
-  pure (negate <$> !(pure xs))
-
-insideRec :: Test
-insideRec = assertEq (Just $ take @Int 10 $ cycle [1, -1]) $ take 10 <$> do
-  rec xs <- Just (1:ys)
-      ys <- pure (negate <$> !(pure xs))
-  pure xs
-
-nested :: Test
-nested = do assertEq "Ab"
-                     !(pure (!(fmap toUpper <$> !(pure getA)) ++ !(!(pure getB))))
-
-lambda :: Test
-lambda = do assertEq "abc!" $ ((\a -> a ++ !getB) !getA) ++ !((\c -> do pure (!c ++ "!")) getC)
-
-insideLet :: Test
-insideLet = do
-  assertEq "abc" !do
-    let a = !getA
-    let b _ = !getB
-    let c = !getC in pure (a ++ b b ++ c)
-
-listComp :: Test
-listComp = assertEq @[Int]
-  [101, 102, 103, 201, 202, 203, 301, 302, 303]
-  [ ![1,2,3] + y | let y = ![100,200,300] ]
-
-monadComp :: Test
-monadComp = do assertEq "abc" ![ !getA ++ b ++ c | let b = !getB, c <- getC ]
-
-parListComp :: Test
-parListComp = assertEq @[Int]
-  [11111, 21111, 12111, 22111, 11221, 21221, 12221, 22221]
-  [ x + y + w + ![1000,2000] + ![10000,20000] | let x = ![1,2], let w = ![10,20] | let y = ![100,200] ]
-
-guards :: Test
-guards | [2,3,4] <- do [![1,2,3] + 1 :: Int] = pure ()
-       | otherwise = error "guards didn't match"
-
-viewPat :: Test
-viewPat = assertEq 9999 x
-  where (do pure (!succ * !pred) -> x) = 100 :: Int
-
-insideWhere :: Test
-insideWhere = do
-  c <- getC
-  assertEq "[2,3,4]c" $ show list ++ c
-  where
-    list = do [![1,2,3] + 1 :: Int]
-
-insideCase :: Test
-insideCase = do
-  assertEq "b"
-    case !getA of
-      (!(pure (++ "_")) -> "d") -> c "abc" ++ s123
-        where c a = !getC ++ a
-              s123 = do pure !"123"
-      "c" -> "d"
-      _a -> "b"
-
-multiWayIf :: Test
-multiWayIf = do
-  assertEq "b" if
-    | !getA == !getA -> !getB
-    | otherwise      -> !getC
-
-usingDoBlockVar :: Test
-usingDoBlockVar = do
-  let a = !getA
-  assertEq "a" !(pure a)
-
-largeExpr :: Test
-largeExpr = do
-  assertEq () !(assertEq () !(assertEq "abc" ![ !getA ++ b ++ c | let b = !getB, c <- getC ]))
-
-confusing :: Test
-confusing = do
-  assertEq @Int 4 $ flip evalState 0 do
-    put 4
-    put 5 >> pure !get
-  assertEq @Int 5 $ flip evalState 0 do
-    put 4
-    put 5
-    pure !get 
-
-qualifiedDo :: Test
-qualifiedDo = do
-  assertEq (5 + 10 + 20 + (5 + 20)) QualifiedDo.do
-    x <- 5
-    10
-    y <- 20
-    x + y
+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE NegativeLiterals #-}++{-# OPTIONS_GHC -fplugin=MonadicBang #-}++module MonadicBang.Test.ShouldPass where+ +import Data.Char+import Control.Monad.Trans.State++import MonadicBang.Test.Utils+import MonadicBang.Test.Utils.QualifiedDo qualified as QualifiedDo+import Control.Monad.IO.Class++shouldPass :: Test+shouldPass = do+  simpleDo+  insideDo+  insideMDo+  insideRec+  nested+  lambda+  insideLet+  listComp+  monadComp+  parListComp+  multiWayIf+  guards+  viewPat+  insideWhere+  insideCase+  usingDoBlockVar+  largeExpr+  confusing+  qualifiedDo++getA, getB, getC :: MonadIO m => m String+getA = pure "a"+getB = pure "b"+getC = pure "c"++simpleDo :: Test+simpleDo = do assertEq "a" !getA++insideDo :: Test+insideDo = do+  let ioA = getA+      nonIOC = !getC+  assertEq "abc" (!ioA ++ !ioB ++ nonIOC)+  where+    ioB = getB++insideMDo :: Test+insideMDo = assertEq (Just $ replicate @Int 10 -1) $ take 10 <$> mdo+  xs <- Just (1:xs)+  pure (negate <$> !(pure xs))++insideRec :: Test+insideRec = assertEq (Just $ take @Int 10 $ cycle [1, -1]) $ take 10 <$> do+  rec xs <- Just (1:ys)+      ys <- pure (negate <$> !(pure xs))+  pure xs++nested :: Test+nested = do assertEq "Ab"+                     !(pure (!(fmap toUpper <$> !(pure getA)) ++ !(!(pure getB))))++lambda :: Test+lambda = do assertEq "abc!" $ ((\a -> a ++ !getB) !getA) ++ !((\c -> do pure (!c ++ "!")) getC)++insideLet :: Test+insideLet = do+  assertEq "abc" !do+    let a = !getA+    let b _ = !getB+    let c = !getC in pure (a ++ b b ++ c)++listComp :: Test+listComp = assertEq @[Int]+  [101, 102, 103, 201, 202, 203, 301, 302, 303]+  [ ![1,2,3] + y | let y = ![100,200,300] ]++monadComp :: Test+monadComp = do assertEq "abc" ![ !getA ++ b ++ c | let b = !getB, c <- getC ]++parListComp :: Test+parListComp = assertEq @[Int]+  [11111, 21111, 12111, 22111, 11221, 21221, 12221, 22221]+  [ x + y + w + ![1000,2000] + ![10000,20000] | let x = ![1,2], let w = ![10,20] | let y = ![100,200] ]++guards :: Test+guards | [2,3,4] <- do [![1,2,3] + 1 :: Int] = pure ()+       | otherwise = error "guards didn't match"++viewPat :: Test+viewPat = assertEq 9999 x+  where (do pure (!succ * !pred) -> x) = 100 :: Int++insideWhere :: Test+insideWhere = do+  c <- getC+  assertEq "[2,3,4]c" $ show list ++ c+  where+    list = do [![1,2,3] + 1 :: Int]++insideCase :: Test+insideCase = do+  assertEq "b"+    case !getA of+      (!(pure (++ "_")) -> "d") -> c "abc" ++ s123+        where c a = !getC ++ a+              s123 = do pure !"123"+      "c" -> "d"+      _a -> "b"++multiWayIf :: Test+multiWayIf = do+  assertEq "b" if+    | !getA == !getA -> !getB+    | otherwise      -> !getC++usingDoBlockVar :: Test+usingDoBlockVar = do+  let a = !getA+  assertEq "a" !(pure a)++largeExpr :: Test+largeExpr = do+  assertEq () !(assertEq () !(assertEq "abc" ![ !getA ++ b ++ c | let b = !getB, c <- getC ]))++confusing :: Test+confusing = do+  assertEq @Int 4 $ flip evalState 0 do+    put 4+    put 5 >> pure !get+  assertEq @Int 5 $ flip evalState 0 do+    put 4+    put 5+    pure !get ++qualifiedDo :: Test+qualifiedDo = do+  assertEq (5 + 10 + 20 + (5 + 20)) QualifiedDo.do+    x <- 5+    10+    y <- 20+    x + y

@@ -1,100 +1,100 @@-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE LambdaCase #-}
-#if MIN_VERSION_ghc(9,6,0)
-{-# LANGUAGE ScopedTypeVariables #-}
-#endif
-{-# LANGUAGE NoFieldSelectors #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE ViewPatterns #-}
-
-module MonadicBang.Test.Utils where
-
-import Control.Monad
-import Data.Foldable
-import Data.Function
-
-import Control.Monad.Trans.Writer.CPS
-
-import GHC.Stack
-
-import GHC
-import GHC.Driver.Errors.Types
-import GHC.Types.Error
-import GHC.Types.SourceError
-import GHC.Utils.Outputable hiding ((<>))
-
-import MonadicBang.Test.Utils.RunGhcParser
-import MonadicBang.Internal.Utils
-import Data.Monoid
-
-data FailType
-  = forall a . Show a => IncorrectResult { expectedValue :: a, actualValue :: a }
-  | forall a . Outputable a => Didn'tFail { expectedFails :: [PsMessage], actualValue :: a }
-  | FailedIncorrectly { expectedFails :: [PsMessage], actualFails :: [GhcMessage] }
-
-data Fail = MkFail { error :: FailType, callStack :: CallStack }
-
-type TestType = WriterT (DList Fail) IO ()
-
-type Test = HasCallStack => TestType
-
-runSuite :: TestType -> IO [Fail]
-runSuite test = fromDList <$> execWriterT test
-
-prettyFail :: Fail -> SDoc
-prettyFail failure = vcat
-  [ case failure.error of
-      IncorrectResult{ expectedValue, actualValue } -> vcat
-        [ text "Expected: " <+> text (show expectedValue)
-        , text "but got:  " <+> text (show actualValue)
-        ]
-      Didn'tFail{ expectedFails } -> vcat
-        [ text "Expected failure with"
-        , nest 2 $ diagnosticsSDoc expectedFails
-        , text "but execution succeeded"
-        ]
-      FailedIncorrectly{ expectedFails, actualFails } -> vcat
-        [ text "Expected failure with"
-        , nest 2 $ diagnosticsSDoc expectedFails
-        , text "but execution failed with these errors instead:"
-        , nest 2 $ diagnosticsSDoc actualFails
-        ]
-  , text "at" <+> text (prettyCallStack failure.callStack)
-  ]
-  where
-    diagnosticsSDoc diags = vcat (map (vcat . unDecorated . diagMsg) diags)
-
-recordFail :: HasCallStack => FailType -> TestType
-recordFail err = tell . Endo . (:) $ MkFail err callStack
-
-assertEq :: (HasCallStack, Show a, Eq a) => a -> a -> TestType
-assertEq expected actual = when (expected /= actual) $
-  withFrozenCallStack $ recordFail $ IncorrectResult expected actual
-
-sdocEq :: SDoc -> SDoc -> Bool
-sdocEq = (==) `on` showSDocUnsafe
-
-assertFailWith :: (HasCallStack, Outputable a) => [PsMessage] -> Either SourceError a -> TestType
-assertFailWith expected = \case
-  Right result -> withFrozenCallStack $ recordFail $ Didn'tFail expected result
-  Left err -> unless sameFails do
-    withFrozenCallStack $ recordFail $ FailedIncorrectly expected errMsgs
-    where
-      errMsgs = toList (srcErrorMessages err)
-      toPsMessage = \case
-        GhcPsMessage m -> Just m
-        _ -> Nothing
-      listEq eq xs ys = and $ zipWith eq xs ys
-      sameFails = maybe False (((listEq . listEq) sdocEq `on` map (unDecorated . diagMsg)) expected) $ traverse toPsMessage errMsgs
-
-diagMsg :: forall a . Diagnostic a => a -> DecoratedSDoc
-#if MIN_VERSION_ghc(9,6,0)
-diagMsg = diagnosticMessage (defaultDiagnosticOpts @a)
-#else
-diagMsg = diagnosticMessage
-#endif
-
-assertParseFailWith :: HasCallStack => [PsMessage] -> String -> TestType
-assertParseFailWith expected source = withFrozenCallStack $
-  assertFailWith expected . fmap pm_parsed_source =<< parseGhc source
+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+#if MIN_VERSION_ghc(9,6,0)+{-# LANGUAGE ScopedTypeVariables #-}+#endif+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE ViewPatterns #-}++module MonadicBang.Test.Utils where++import Control.Monad+import Data.Foldable+import Data.Function++import Control.Monad.Trans.Writer.CPS++import GHC.Stack++import GHC+import GHC.Driver.Errors.Types+import GHC.Types.Error+import GHC.Types.SourceError+import GHC.Utils.Outputable hiding ((<>))++import MonadicBang.Test.Utils.RunGhcParser+import MonadicBang.Internal.Utils+import Data.Monoid++data FailType+  = forall a . Show a => IncorrectResult { expectedValue :: a, actualValue :: a }+  | forall a . Outputable a => Didn'tFail { expectedFails :: [PsMessage], actualValue :: a }+  | FailedIncorrectly { expectedFails :: [PsMessage], actualFails :: [GhcMessage] }++data Fail = MkFail { error :: FailType, callStack :: CallStack }++type TestType = WriterT (DList Fail) IO ()++type Test = HasCallStack => TestType++runSuite :: TestType -> IO [Fail]+runSuite test = fromDList <$> execWriterT test++prettyFail :: Fail -> SDoc+prettyFail failure = vcat+  [ case failure.error of+      IncorrectResult{ expectedValue, actualValue } -> vcat+        [ text "Expected: " <+> text (show expectedValue)+        , text "but got:  " <+> text (show actualValue)+        ]+      Didn'tFail{ expectedFails } -> vcat+        [ text "Expected failure with"+        , nest 2 $ diagnosticsSDoc expectedFails+        , text "but execution succeeded"+        ]+      FailedIncorrectly{ expectedFails, actualFails } -> vcat+        [ text "Expected failure with"+        , nest 2 $ diagnosticsSDoc expectedFails+        , text "but execution failed with these errors instead:"+        , nest 2 $ diagnosticsSDoc actualFails+        ]+  , text "at" <+> text (prettyCallStack failure.callStack)+  ]+  where+    diagnosticsSDoc diags = vcat (map (vcat . unDecorated . diagMsg) diags)++recordFail :: HasCallStack => FailType -> TestType+recordFail err = tell . Endo . (:) $ MkFail err callStack++assertEq :: (HasCallStack, Show a, Eq a) => a -> a -> TestType+assertEq expected actual = when (expected /= actual) $+  withFrozenCallStack $ recordFail $ IncorrectResult expected actual++sdocEq :: SDoc -> SDoc -> Bool+sdocEq = (==) `on` showSDocUnsafe++assertFailWith :: (HasCallStack, Outputable a) => [PsMessage] -> Either SourceError a -> TestType+assertFailWith expected = \case+  Right result -> withFrozenCallStack $ recordFail $ Didn'tFail expected result+  Left err -> unless sameFails do+    withFrozenCallStack $ recordFail $ FailedIncorrectly expected errMsgs+    where+      errMsgs = toList (srcErrorMessages err)+      toPsMessage = \case+        GhcPsMessage m -> Just m+        _ -> Nothing+      listEq eq xs ys = and $ zipWith eq xs ys+      sameFails = maybe False (((listEq . listEq) sdocEq `on` map (unDecorated . diagMsg)) expected) $ traverse toPsMessage errMsgs++diagMsg :: forall a . Diagnostic a => a -> DecoratedSDoc+#if MIN_VERSION_ghc(9,6,0)+diagMsg = diagnosticMessage (defaultDiagnosticOpts @a)+#else+diagMsg = diagnosticMessage+#endif++assertParseFailWith :: HasCallStack => [PsMessage] -> String -> TestType+assertParseFailWith expected source = withFrozenCallStack $+  assertFailWith expected . fmap pm_parsed_source =<< parseGhc source

@@ -1,13 +1,13 @@-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module MonadicBang.Test.Utils.QualifiedDo where
-
-import Prelude (Int, (+), const)
-
-(>>=) :: Int -> (Int -> Int) -> Int
-a >>= f = a + f a
-
-(>>) :: Int -> Int -> Int
-a >> b = a >>= const b
+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++module MonadicBang.Test.Utils.QualifiedDo where++import Prelude (Int, (+), const)++(>>=) :: Int -> (Int -> Int) -> Int+a >>= f = a + f a++(>>) :: Int -> Int -> Int+a >> b = a >>= const b

@@ -1,92 +1,101 @@-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE CPP #-}
-
-{-# OPTIONS -fplugin=MonadicBang #-}
-
--- | This module makes it possible to run GHC's Parser with plugins on source
--- files, and check what (if any) errors it produced
-module MonadicBang.Test.Utils.RunGhcParser where
-
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Except
-#if !MIN_VERSION_ghc(9,10,0)
-import Data.Foldable
-#endif
-
-import GHC
-import GHC.Driver.Plugins
-import GHC.Driver.Env.Types
-import GHC.Driver.Config.Finder
-import GHC.Driver.Session
-import GHC.LanguageExtensions qualified as LangExt
-import GHC.Data.EnumSet qualified as ES
-import GHC.Data.StringBuffer
-import GHC.Settings.IO
-import GHC.Types.SourceFile
-import GHC.Types.SourceError
-import GHC.Unit.Types
-import GHC.Unit.Finder
-import GHC.Utils.Fingerprint
-
-import GHC.Paths qualified
-
-import MonadicBang qualified
-
--- | Parses a module
-parseGhc :: MonadIO m => String -> m (Either SourceError ParsedModule)
-parseGhc src = do
-  let dflags = !initialDynFlags
-      modNameStr = "MonadicBang.Test.Tmp"
-      modName = mkModuleName modNameStr
-      modSummary = ModSummary
-        { ms_mod = mkModule (stringToUnit modNameStr) modName
-        , ms_hsc_src = HsSrcFile
-        , ms_location = mkHomeModLocation (initFinderOpts dflags) modName (error "monadic-bang (test suite): no home path")
-        , ms_hs_hash = fingerprintString src
-        , ms_obj_date = Nothing
-        , ms_dyn_obj_date = Nothing
-        , ms_iface_date = Nothing
-        , ms_hie_date = Nothing
-        , ms_srcimps = []
-        , ms_textual_imps = []
-        , ms_ghc_prim_import = False
-        , ms_parsed_mod = Nothing
-        , ms_hspp_file = modNameStr
-        , ms_hspp_opts = dflags
-        , ms_hspp_buf = Just $ stringToStringBuffer src
-        }
-  runDefaultGhc dflags . handleSourceError (pure . Left) $
-    Right <$> parseModule modSummary
-
-runDefaultGhc :: MonadIO m => DynFlags -> Ghc a -> m a
-runDefaultGhc dflags action = liftIO do
-  runGhc (Just GHC.Paths.libdir) (do setSessionDynFlags dflags >> addPlugin >> action)
-  where
-    addPlugin = do
-      let session = !getSession
-          plugins = hsc_plugins session
-      setSession (session{hsc_plugins = plugins{staticPlugins = StaticPlugin
-        { spPlugin = PluginWithArgs MonadicBang.plugin []
-#if MIN_VERSION_ghc(9,12,0)
-        , spInitialised = False
-#endif
-        } : staticPlugins plugins}})
-
-initialDynFlags :: MonadIO m => m DynFlags
-initialDynFlags = do
-  dflags <- withExts
-  pure $ dflags{generalFlags = ES.insert Opt_ImplicitImportQualified $ generalFlags dflags}
-  where
-#if MIN_VERSION_ghc(9,6,0)
-    withExts = do pure $ foldl' xopt_set (defaultDynFlags !settings') $ exts
-#else
-    withExts = do pure $ foldl' xopt_set (defaultDynFlags !settings' $ error "llvmConfig") $ exts
-#endif
-    exts = [LangExt.LambdaCase]
-
-settings' :: MonadIO m => m Settings
-settings' = either (error . showSettingsError) id <$> runExceptT (initSettings GHC.Paths.libdir)
-  where
-    showSettingsError (SettingsError_MissingData s) = s
-    showSettingsError (SettingsError_BadData s) = s
+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}++{-# OPTIONS -fplugin=MonadicBang #-}++-- | This module makes it possible to run GHC's Parser with plugins on source+-- files, and check what (if any) errors it produced+module MonadicBang.Test.Utils.RunGhcParser where++import Control.Monad.IO.Class+import Control.Monad.Trans.Except+#if !MIN_VERSION_ghc(9,10,0)+import Data.Foldable+#endif+#if MIN_VERSION_ghc(9,14,0)+import System.OsPath (unsafeEncodeUtf)+#endif++import GHC+import GHC.Driver.Plugins+import GHC.Driver.Env.Types+import GHC.Driver.Config.Finder+import GHC.Driver.Session+import GHC.LanguageExtensions qualified as LangExt+import GHC.Data.EnumSet qualified as ES+import GHC.Data.StringBuffer+import GHC.Settings.IO+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Unit.Types+import GHC.Unit.Finder+import GHC.Utils.Fingerprint++import GHC.Paths qualified++import MonadicBang qualified++-- | Parses a module+parseGhc :: MonadIO m => String -> m (Either SourceError ParsedModule)+parseGhc src = do+  let dflags = !initialDynFlags+      modNameStr = "MonadicBang.Test.Tmp"+      modName = mkModuleName modNameStr+      modSummary = ModSummary+        { ms_mod = mkModule (stringToUnit modNameStr) modName+        , ms_hsc_src = HsSrcFile+#if MIN_VERSION_ghc(9,14,0)+        , ms_location = mkHomeModLocation (initFinderOpts dflags) modName (error "monadic-bang (test suite): no home path") (unsafeEncodeUtf "hs") HsSrcFile+#else+        , ms_location = mkHomeModLocation (initFinderOpts dflags) modName (error "monadic-bang (test suite): no home path")+#endif+        , ms_hs_hash = fingerprintString src+        , ms_obj_date = Nothing+        , ms_dyn_obj_date = Nothing+        , ms_iface_date = Nothing+        , ms_hie_date = Nothing+        , ms_srcimps = []+        , ms_textual_imps = []+#if !MIN_VERSION_ghc(9,14,0)+        , ms_ghc_prim_import = False+#endif+        , ms_parsed_mod = Nothing+        , ms_hspp_file = modNameStr+        , ms_hspp_opts = dflags+        , ms_hspp_buf = Just $ stringToStringBuffer src+        }+  runDefaultGhc dflags . handleSourceError (pure . Left) $+    Right <$> parseModule modSummary++runDefaultGhc :: MonadIO m => DynFlags -> Ghc a -> m a+runDefaultGhc dflags action = liftIO do+  runGhc (Just GHC.Paths.libdir) (do setSessionDynFlags dflags >> addPlugin >> action)+  where+    addPlugin = do+      let session = !getSession+          plugins = hsc_plugins session+      setSession (session{hsc_plugins = plugins{staticPlugins = StaticPlugin+        { spPlugin = PluginWithArgs MonadicBang.plugin []+#if MIN_VERSION_ghc(9,12,0)+        , spInitialised = False+#endif+        } : staticPlugins plugins}})++initialDynFlags :: MonadIO m => m DynFlags+initialDynFlags = do+  dflags <- withExts+  pure $ dflags{generalFlags = ES.insert Opt_ImplicitImportQualified $ generalFlags dflags}+  where+#if MIN_VERSION_ghc(9,6,0)+    withExts = do pure $ foldl' xopt_set (defaultDynFlags !settings') $ exts+#else+    withExts = do pure $ foldl' xopt_set (defaultDynFlags !settings' $ error "llvmConfig") $ exts+#endif+    exts = [LangExt.LambdaCase]++settings' :: MonadIO m => m Settings+settings' = either (error . showSettingsError) id <$> runExceptT (initSettings GHC.Paths.libdir)+  where+    showSettingsError (SettingsError_MissingData s) = s+    showSettingsError (SettingsError_BadData s) = s