packages feed

monadic-bang (empty) → 0.1.0.0

raw patch · 16 files changed

+1542/−0 lines, 16 filesdep +basedep +containersdep +exceptions

Dependencies added: base, containers, exceptions, fused-effects, ghc, ghc-boot, ghc-paths, monadic-bang, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for monadic-bang++## 0.1.0.0 -- 2023-01-07++* First version. Released on an unsuspecting world.
+ README.md view
@@ -0,0 +1,394 @@+# Monadic Bang++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 -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 then 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 kind of just special `do`-blocks, so `!` can be used here as well (and also 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 <- ...` at the end here instead of the beginning is that everything that appears to the left of the `|` in a list comprehension is essentially comparable to 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 would not work for e.g. `whileM`. In implementations of `whileM`, the condition is re-evaluated after every iteration. If you wrote e.g. `while (!(readIORef i) > 0)`, it would only be evaluated once, before the first 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.+- 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`.++## 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 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 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.cabal view
@@ -0,0 +1,121 @@+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.1.0.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 files to be distributed with the package, such as examples or a README.+extra-source-files:+    CHANGELOG.md+    README.md++library+    -- Modules exported by the library.+    exposed-modules:  MonadicBang+                      MonadicBang.Internal+                      MonadicBang.Effect.Offer+                      MonadicBang.Effect.Uniques+                      MonadicBang.Effect.Writer.Discard+                      MonadicBang.Options+                      MonadicBang.Utils+                      MonadicBang.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 && < 5,+                      ghc >= 9.4,+                      containers ^>= 0.6.4.1,+                      transformers ^>= 0.5.6.2,+                      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+                      MonadicBang.Test.ShouldPass+                      MonadicBang.Test.ShouldFail++    -- Test dependencies.+    build-depends:    base,+                      ghc,+                      ghc-boot >= 9.4,+                      ghc-paths ^>= 0.1.0.12,+                      transformers,+                      exceptions ^>= 0.10,+                      monadic-bang++    ghc-options:      -Wall -Wcompat -plugin-package=monadic-bang
+ src/MonadicBang.hs view
@@ -0,0 +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+  }
+ src/MonadicBang/Effect/Offer.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedRecordDot #-}++module MonadicBang.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 #-}
+ src/MonadicBang/Effect/Uniques.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedRecordDot #-}++module MonadicBang.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 #-}
+ src/MonadicBang/Effect/Writer/Discard.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE GADTs #-}++-- | A Writer carrier that discards any values it is told+module MonadicBang.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
+ src/MonadicBang/Error.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE LambdaCase #-}++module MonadicBang.Error where++import Prelude hiding ((<>))++import Control.Effect.Writer++import GHC+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+customError = PsUnknownMessage . \cases+  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 " <> 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 $ MsgEnvelope srcSpan neverQualify err SevError
+ src/MonadicBang/Internal.hs view
@@ -0,0 +1,430 @@+{-# 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 #-}++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 Debug.Trace++import GHC.Utils.Logger++import MonadicBang.Effect.Offer+import MonadicBang.Effect.Uniques+import MonadicBang.Options+import MonadicBang.Utils+import MonadicBang.Error++import Data.Kind+import MonadicBang.Effect.Writer.Discard++-- 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+  traceShow cmdLineOpts $ pure ()+  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+    AsPat xa name pat -> do+      tellName name+      AsPat xa name <$> traverse (liftMaybeT . evacPats) pat++    _ -> 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
+ src/MonadicBang/Options.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}++module MonadicBang.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}++parseOptions :: Has (Throw ErrorCall) sig m => Located HsModule -> [CommandLineOption] -> m Options+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
+ src/MonadicBang/Utils.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE MonoLocalBinds #-}++module MonadicBang.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++-- This is included in transformers 0.6, but that can't be used together with ghc 9.4+{-# INLINE hoistMaybe #-}+hoistMaybe :: Applicative m => Maybe a -> MaybeT m a+hoistMaybe = MaybeT . pure++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"
+ test/MonadicBang/Test.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LexicalNegation #-}+{-# LANGUAGE MonadComprehensions #-}++module Main (main) where++import MonadicBang.Test.ShouldPass+import MonadicBang.Test.ShouldFail++main :: IO ()+main = do+  shouldPass+  shouldFail
+ test/MonadicBang/Test/ShouldFail.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE LambdaCase #-}++module MonadicBang.Test.ShouldFail (shouldFail) where++import MonadicBang.Test.Utils+import MonadicBang.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\+\"
+ test/MonadicBang/Test/ShouldPass.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE NegativeLiterals #-}++{-# OPTIONS -fplugin=MonadicBang -fplugin-opt=MonadicBang:-ddump #-}++module MonadicBang.Test.ShouldPass where+ +import Data.Char+import Control.Monad.Trans.State++import MonadicBang.Test.Utils++shouldPass :: Test+shouldPass = do+  simpleDo+  insideDo+  insideMDo+  insideRec+  nested+  lambda+  insideLet+  listComp+  monadComp+  parListComp+  multiWayIf+  guards+  viewPat+  insideWhere+  insideCase+  usingDoBlockVar+  largeExpr+  confusing++getA, getB, getC :: IO 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
+ test/MonadicBang/Test/Utils.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}++module MonadicBang.Test.Utils where++import Control.Monad+import Data.Foldable+import Data.Function++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++-- TODO: This should use a Writer to collect all errors+type Test = HasCallStack => IO ()++assertEq :: (HasCallStack, Show a, Eq a) => a -> a -> IO ()+-- We don't care about seeing where the `error` call itself happens in the+-- call stack, so we freeze it+assertEq expected actual = when (expected /= actual) $ withFrozenCallStack do+  error $ "Expected " <> show expected <> ", but got " <> show actual++assertFailWith :: (HasCallStack, Outputable a) => [PsMessage] -> Either SourceError a -> IO ()+assertFailWith expected = \case+  Right result -> withFrozenCallStack $ error . showSDocUnsafe $+    text "\n    Expected failure with" $$+    diagnosticsSDoc expected $$+    text "    but execution succeeded with this result:" $$+    ppr result+  Left err -> unless sameErrors do+    error . showSDocUnsafe $+      text "\n    Expected failure with" $$+      diagnosticsSDoc expected $$+      text "    but execution failed with these errors instead:" $$+      diagnosticsSDoc errMsgs+    where+      errMsgs = toList (srcErrorMessages err)+      toPsMessage = \case+        GhcPsMessage m -> Just m+        _ -> Nothing+      sameErrors = maybe False (((==) `on` map (unDecorated . diagnosticMessage)) expected) $ traverse toPsMessage errMsgs+  where+    diagnosticsSDoc diags = vcat (map (vcat . unDecorated . diagnosticMessage) diags)++assertParseFailWith :: HasCallStack => [PsMessage] -> String -> IO ()+assertParseFailWith expected source = withFrozenCallStack do+  assertFailWith expected . fmap pm_parsed_source =<< parseGhc source
+ test/MonadicBang/Test/Utils/RunGhcParser.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE BlockArguments #-}++{-# 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 "/home/user/tmp/nothing"+        , 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+    withExts = do pure $ foldl' xopt_set (defaultDynFlags !settings' llvmConfig') $ exts+    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++llvmConfig' :: LlvmConfig+llvmConfig' = error "llvmConfig"