Opened 2 years ago

Closed 8 months ago

#13648 closed bug (worksforme)

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

Reported by: AaronFriel Owned by:
Priority: normal Milestone:
Component: Compiler Version: 8.2.1-rc1
Keywords: ApplicativeDo Cc: simonmar
Operating System: Unknown/Multiple Architecture: Unknown/Multiple
Type of failure: GHC rejects valid program Test Case:
Blocked By: Blocking:
Related Tickets: Differential Rev(s):
Wiki Page:

Description (last modified by AaronFriel)

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).


{-# 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
    return ()

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

main = print "42"
:t 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 =
           (\ 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?

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 ()))

Change History (5)

comment:1 Changed 2 years ago by AaronFriel

Description: modified (diff)

comment:2 Changed 2 years ago by simonpj

Keywords: ApplicativeDo added

comment:3 Changed 2 years ago by bgamari

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

comment:4 Changed 2 years ago by AaronFriel

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:

comment:5 Changed 8 months ago by josef

Resolution: worksforme
Status: newclosed

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.

Note: See TracTickets for help on using tickets.