monadic-bang 0.1.0.0 → 0.1.1.0

raw patch · 11 files changed

+103/−26 lines, 11 filesdep ~ghcdep ~ghc-bootdep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc, ghc-boot, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +11/−8
• monadic-bang.cabal +13/−6
• src/MonadicBang/Error.hs +6/−1
• src/MonadicBang/Internal.hs +7/−3
• src/MonadicBang/Options.hs +5/−0
• src/MonadicBang/Utils.hs +4/−0
• test/MonadicBang/Test/ShouldPass.hs +12/−1
• test/MonadicBang/Test/Utils.hs +17/−2
• test/MonadicBang/Test/Utils/QualifiedDo.hs +13/−0
• test/MonadicBang/Test/Utils/RunGhcParser.hs +7/−5

@@ -1,5 +1,13 @@ # Revision history for monadic-bang +## 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.

@@ -144,7 +144,7 @@ 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 #-}+{-# OPTIONS_GHC -fplugin=MonadicBang #-} ```  to the top of the files you want to use it in.@@ -154,7 +154,7 @@ 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.+- `-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 @@ -183,7 +183,7 @@ do putStrLn !(readFile (!getArgs !! 1)) ``` -For how this is desugared, see [Desugaring](#desugaring)+For how this is desugared, see [Desugaring](#desugaring).  ### Using `-XQualifiedDo` @@ -213,7 +213,7 @@  ### List comprehensions -List comprehensions are kind of just special `do`-blocks, so `!` can be used here as well (and also in monad comprehensions). Example:+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]] ]@@ -223,7 +223,7 @@ [ 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`).+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 `<-` @@ -241,7 +241,7 @@   ... ``` -⚠️ 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.+⚠️ 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 @@ -250,6 +250,7 @@ - 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@@ -265,6 +266,8 @@      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@@ -305,7 +308,7 @@  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.+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: @@ -390,5 +393,5 @@ 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)+- 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

@@ -14,7 +14,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:            0.1.0.0+version:            0.1.1.0  -- A short (one-line) description of the package. synopsis:           GHC plugin to desugar ! into do-notation@@ -45,11 +45,17 @@ -- copyright: category:           Development --- Extra files to be distributed with the package, such as examples or a README.-extra-source-files:+extra-doc-files:     CHANGELOG.md     README.md +tested-with:        GHC == 9.4.5+                    GHC == 9.6.2++source-repository head+    type:           git+    location:       https://github.com/JakobBruenker/monadic-bang.git+ library     -- Modules exported by the library.     exposed-modules:  MonadicBang@@ -78,9 +84,9 @@      -- Other library packages from which modules are imported.     build-depends:    base >=4.17.0.0 && < 5,-                      ghc >= 9.4,+                      ghc >= 9.4 && < 9.7,                       containers ^>= 0.6.4.1,-                      transformers ^>= 0.5.6.2,+                      transformers >= 0.5.6.2 && < 0.7,                       fused-effects ^>= 1.1.1.2,      -- Directories containing source files.@@ -105,6 +111,7 @@     main-is:          MonadicBang/Test.hs      other-modules:    MonadicBang.Test.Utils.RunGhcParser+                      MonadicBang.Test.Utils.QualifiedDo                       MonadicBang.Test.Utils                       MonadicBang.Test.ShouldPass                       MonadicBang.Test.ShouldFail@@ -112,7 +119,7 @@     -- Test dependencies.     build-depends:    base,                       ghc,-                      ghc-boot >= 9.4,+                      ghc-boot >= 9.4 && < 9.7,                       ghc-paths ^>= 0.1.0.12,                       transformers,                       exceptions ^>= 0.10,

@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}  module MonadicBang.Error where @@ -18,14 +19,18 @@ type PsErrors = Writer (Messages PsError)  customError :: Error -> PsError+#if 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 " <> ppr name <> text " cannot be used inside of ! here, since its desugaring would escape its scope"]+    { 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?"]     }

@@ -11,6 +11,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}  module MonadicBang.Internal where @@ -41,8 +42,6 @@ import GHC.Utils.Monad (concatMapM, whenM) import Text.Printf -import Debug.Trace- import GHC.Utils.Logger  import MonadicBang.Effect.Offer@@ -116,7 +115,6 @@ 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 .@@ -267,9 +265,15 @@   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

@@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE CPP #-}  module MonadicBang.Options where @@ -22,7 +23,11 @@  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

@@ -1,4 +1,5 @@ {-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE CPP #-}  module MonadicBang.Utils where @@ -23,10 +24,13 @@ (??) :: Functor f => f (a -> b) -> a -> f b fs ?? x = ($ x) <$> fs +#if MIN_VERSION_ghc(9,6,0)+#else -- 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+#endif  panic :: HasCallStack => String -> a panic message = withFrozenCallStack $ error $

@@ -1,4 +1,5 @@ {-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ViewPatterns #-}@@ -6,7 +7,7 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NegativeLiterals #-} -{-# OPTIONS -fplugin=MonadicBang -fplugin-opt=MonadicBang:-ddump #-}+{-# OPTIONS_GHC -fplugin=MonadicBang #-}  module MonadicBang.Test.ShouldPass where  @@ -14,6 +15,7 @@ import Control.Monad.Trans.State  import MonadicBang.Test.Utils+import MonadicBang.Test.Utils.QualifiedDo qualified as QualifiedDo  shouldPass :: Test shouldPass = do@@ -35,6 +37,7 @@   usingDoBlockVar   largeExpr   confusing+  qualifiedDo  getA, getB, getC :: IO String getA = pure "a"@@ -139,3 +142,11 @@     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,5 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-}+#if MIN_VERSION_ghc(9,6,0)+{-# LANGUAGE ScopedTypeVariables #-}+#endif  module MonadicBang.Test.Utils where @@ -26,6 +30,9 @@ assertEq expected actual = when (expected /= actual) $ withFrozenCallStack do   error $ "Expected " <> show expected <> ", but got " <> show actual +sdocEq :: SDoc -> SDoc -> Bool+sdocEq = (==) `on` showSDocUnsafe+ assertFailWith :: (HasCallStack, Outputable a) => [PsMessage] -> Either SourceError a -> IO () assertFailWith expected = \case   Right result -> withFrozenCallStack $ error . showSDocUnsafe $@@ -44,9 +51,17 @@       toPsMessage = \case         GhcPsMessage m -> Just m         _ -> Nothing-      sameErrors = maybe False (((==) `on` map (unDecorated . diagnosticMessage)) expected) $ traverse toPsMessage errMsgs+      listEq eq xs ys = and $ zipWith eq xs ys+      sameErrors = maybe False (((listEq . listEq) sdocEq `on` map (unDecorated . diagMsg)) expected) $ traverse toPsMessage errMsgs   where-    diagnosticsSDoc diags = vcat (map (vcat . unDecorated . diagnosticMessage) diags)+    diagnosticsSDoc diags = vcat (map (vcat . unDecorated . diagMsg) diags)++    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 -> IO () assertParseFailWith expected source = withFrozenCallStack do

@@ -0,0 +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

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}  {-# OPTIONS -fplugin=MonadicBang #-} @@ -39,7 +40,7 @@       modSummary = ModSummary         { ms_mod = mkModule (stringToUnit modNameStr) modName         , ms_hsc_src = HsSrcFile-        , ms_location = mkHomeModLocation (initFinderOpts dflags) modName "/home/user/tmp/nothing"+        , ms_location = mkHomeModLocation (initFinderOpts dflags) modName ""         , ms_hs_hash = fingerprintString src         , ms_obj_date = Nothing         , ms_dyn_obj_date = Nothing@@ -70,7 +71,11 @@   dflags <- withExts   pure $ dflags{generalFlags = ES.insert Opt_ImplicitImportQualified $ generalFlags dflags}   where-    withExts = do pure $ foldl' xopt_set (defaultDynFlags !settings' llvmConfig') $ exts+#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@@ -78,6 +83,3 @@   where     showSettingsError (SettingsError_MissingData s) = s     showSettingsError (SettingsError_BadData s) = s--llvmConfig' :: LlvmConfig-llvmConfig' = error "llvmConfig"