ApplicativeDo selects "GHC.Base.Monad.return" when actions are used without patterns.

GHC 8.0.2 and 8.2.1-rc1 (rc2 not checked) have a bug where -XApplicativeDo causes "GHC.Base.Monad.return" to be used instead of the locally available "return", and a spurious "return ()" shows up. This desugaring is not adhering to the -XRebindableSyntax spec (see: #12490 (closed)).

Example:

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RebindableSyntax  #-}
-- Bug vanishes if this next line is removed:
{-# LANGUAGE ApplicativeDo  #-}

module Main where

import Prelude (String, print)

class MyFunctor f where
    fmap :: (a -> b) -> f a -> f b

class MyApplicative f where
    pure :: a -> f a
    (<*>) :: f (a -> b) -> f a -> f b

class MyMonad m where
    return :: a -> m a
    (>>) :: m a -> m b -> m b
    (>>=) :: m a -> (a -> m b) -> m b
    fail :: String -> m a
    join :: m (m a) -> m a

testCase1 m1 m2 = do
    m1
    m2
    return ()

testCase2 m1 m2 = do
    _ <- m1
    _ <- m2
    return ()

main = print "42"

:t testCase1
testCase1
  :: (MyFunctor f, MyApplicative f, MyMonad f, Monad f) =>
     f a2 -> f a1 -> f ()

:t testCase2
  :: testCase2 :: (MyFunctor f, MyApplicative f) => f t -> f a -> f ()

The desugaring for testCase1 shows the issue:

testCase1' m1 m2 =
      (<*>)
        (fmap
           (\ r1 r2 ->
              case r1 of { () -> case r2 of { () -> () } })
           (m1 >> (GHC.Base.Monad.return ())))
        (m2 >> (GHC.Base.Monad.return ()))
-- or:
testCase1'' m1 m2 = (fmap (\() () -> () ) (m1 >> (GHC.Base.Monad.return ()))) <*> (m2 >> (GHC.Base.Monad.return ()))

I would be able to work on this if someone pointed me in the right direction. It looks like it would be in compiler/rename/RnEnv and compiler/rename/RnExpr, as with #12490 (closed)?

As a proposed fix, I would want to implement a limited-scope fix before the 8.2.1 release which would not address the thornier issue of #10892. The patch would:

1. Replace GHC.Base.Monad.return with local pure, removing the Monad constraint.
2. Replace >> with *>, removing the MyMonad constraint.

This isn't a complete fix, as this would still leave the unnecessary pattern matches in the use of fmap. The resulting desugaring would be:

testCase1''' m1 m2 = (fmap (\() () -> () ) (m1 *> (pure ()))) <*> (m2 *> (pure ()))

changed weight to 5

added Tbug Trac import labels

changed the description

mentioned in issue #13649 (closed)

added ApplicativeDo label

As you point out, the relevant bit of code is in RnExpr. In particular, I believe that stmtTreeToStmts is relevant.

This turns out to be easier than I expected, which makes me expect it broke something else.

The issue seems to be that the desugaring for ApplicativeDo had no casse for a BodyStmt. This was absent in three places: stmtTreeToStmts, stmtTreeArg, and slurpIndependentStmts.

By adding a pattern match on BodyStmt and substituting the pattern where necessary with nlWildPatName, the desugaring now treats BodyStmt everywhere as a BindStmt with a wildcard pattern. This seems to work properly. Here is the renamer output before:

Main.testCase1 m1_a1O4 m2_a1O5
  = do () <- do m1_a1O4
                GHC.Base.return () |
       () <- do m2_a1O5
                GHC.Base.return ()
       return ()

After adding the additional case to stmtTreeToStmts, I found the output was this:

Main.testCase1 m1_a259 m2_a25a
  = do () <- do _ <- m1_a259
                () |
       () <- do _ <- m2_a25a
                ()
       return () 

While this ought to optimize just as well, it was clear the body statements were being grouped into separate applicative segments. To make sure this is handled correctly, I modified stmtTreeArg and slurpIndependentStmts as well. Now the renamer outputs the same AST for both wildcard pattern binds and body statements:

Main.testCase1 m1_a1N9 m2_a1Na
  = do _ <- m1_a1N9 | _ <- m2_a1Na
       return ()
Main.testCase2 m1_a1Nf m2_a1Ng
  = do _ <- m1_a1Nf | _ <- m2_a1Ng
       return () 

I think if I did this correctly, the patch is pushed to phabricator here: https://phabricator.haskell.org/D3552

closed

I'm not seeing the reported behaviour with the latest GHC. I get the expected type signatures:

*Main> :t testCase1
testCase1 :: (MyFunctor f, MyApplicative f) => f t -> f a -> f ()
*Main> :t testCase2
testCase2 :: (MyFunctor f, MyApplicative f) => f t -> f a -> f ()

So I'm closing this ticket. Reopen if you disagree.

Trac metadata

Trac field	Value
Resolution	Unresolved → ResolvedWorksForMe

added Pnormal label