monadic-bang 0.2.1.0 → 0.2.2.0

raw patch · 17 files changed

+1745/−1706 lines, 17 filesdep ~basedep ~ghcdep ~ghc-bootPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, ghc, ghc-boot

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−18
• README.md +399/−399
• monadic-bang.cabal +129/−128
• src/MonadicBang.hs +13/−13
• src/MonadicBang/Internal.hs +466/−434
• 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 +87/−85

@@ -1,18 +1,22 @@-# Revision history for monadic-bang--## 0.2.0.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. Released on an unsuspecting world.+# Revision history for monadic-bang
+
+## 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,128 +1,129 @@-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.1.0---- 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--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.20,-                      ghc >=9.4 && <9.9,-                      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.9,-                      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.0
+
+-- 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
+
+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.21,
+                      ghc >=9.4 && <9.11,
+                      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.11,
+                      ghc-paths ^>=0.1.0.12,
+                      transformers,
+                      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,434 +1,466 @@-{-# 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---- 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---- | 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 :: OccSet , invalid :: OccSet}--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 emptyOccSet emptyOccSet--addValid :: OccName -> InScope -> InScope-addValid name inScope = inScope{valid = extendOccSet inScope.valid name}--addValids :: OccSet -> InScope -> InScope-addValids names inScope = inScope{valid = inScope.valid <> names}--invalidateVars :: InScope -> InScope-invalidateVars inScope = MkInScope{valid = emptyOccSet, invalid = inScope.valid <> inScope.invalid}--isInvalid :: Has (Reader InScope) sig m => OccName -> m Bool-isInvalid name = do-  inScope <- ask @InScope-  pure $ name `elemOccSet` 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 _ (ParsedResult (HsParsedModule mod' files) msgs) = do-  options <- liftIO . (either throwIO pure =<<) . runThrow @ErrorCall $ parseOptions mod' cmdLineOpts-  dflags <- getDynFlags-  (newErrors, mod'') <--    runM .-    runUniquesIO 'p' .-    runWriter .-    runReader options .-    runReader noneInScope .-    evalWriter @OccSet .-    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,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) l.locA-        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)-      HsLet xl letTok binds inTok ex -> do-        (boundVars, binds') <- runWriter @OccSet $ evac binds-        fmap (L l . HsLet xl letTok binds' inTok) <$> liftMaybeT . local (addValids boundVars) $ evac ex--      _ -> 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 OccSet--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 EpAnnNotUsed 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 spn.locA 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 OccSet) sig m => OccName -> m ()-tellLocalVar = tell . unitOccSet+{-# 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 _ (ParsedResult (HsParsedModule mod' files) msgs) = 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

@@ -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,85 +1,87 @@-{-# 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-import Data.Foldable--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 ""-        , 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 (PluginWithArgs MonadicBang.plugin []) : 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
+
+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 ""
+        , 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 (PluginWithArgs MonadicBang.plugin []) : 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