compiler: fix trac issue 13648
Needs RevisionPublic

Authored by AaronFriel on May 9 2017, 2:19 AM.

Details

Reviewers
bgamari
simonmar
austin
Trac Issues
#13648
#12143
Summary

This adds cases to three functions in RnExpr for ApplicativeDo desugaring. In
each, a case is added to treat BodyStmt as a BindStmt with a wildcard pattern.
This allows bind statements and body statements to coexist in a do.

This fixes https://ghc.haskell.org/trac/ghc/ticket/13648 and https://ghc.haskell.org/trac/ghc/ticket/12143, by correctly handling the body statement.

AaronFriel created this revision.May 9 2017, 2:19 AM

Ok, so there are a couple of problems with this approach

  • We have to ensure that transformed code doesn't appear in error messages from the typechecker. Right now things are delicately arranged so that when we print out the renamed code we get the original source code, but I think transforming BodyStmt into ApplicativeArgOne will break this.
  • What we really want to do with BodyStmts is to use *> and <* since these can be more efficient: https://ghc.haskell.org/trac/ghc/ticket/10892
AaronFriel added a comment.EditedMay 9 2017, 11:16 AM

I understand that the *> and <* transformation would be significantly more complex, and I wanted to avoid that while still solving an issue that results in highly unidiomatic code to be able to use ApplicativeDo with an alternative Functor-Applicative-Monad stack:

In this code snippet, the wildcard patterns are necessary or the code generation is wrong.

t3_once z = do
    x <- get @Int
    y <- get @Float
    _ <- trace ("x : " ++ show x)
    _ <- trace ("y : " ++ show y)
    let y' = log (fromIntegral x * y + fromIntegral z)
        x' = (x + round y + z) `div` 2
    _ <- put @Float y'
    _ <- put @Int x'
    return $ x' + round y' + z `div` 2

Is there a way to get this to work without tackling https://ghc.haskell.org/trac/ghc/ticket/10892?

Edit: By wrong I mean it introduces Monad constraints which are unsolveable. Since this is an alternative class hierarchy, Monad does not make sense. This is the type I should get:

t3_once :: Int 
        -> Eff u (('Fmapped ('Do (Get Int)) ':<*> 'Do (Get Float)) 
                '  :>>= 'TLeaf 
                        (('Fmapped ('Do Trace) ':<*> 'Do Trace)
                          ':<*>
                         ('Fmapped ('Do (Put Float)) ':<*> 'Do (Put Int)))) Int

Instead, due to #13648, each body statement is transformed to () <- do stmt | GHC.Monad.Base.return (), using the notation from the renamer.

The result is this:

t3_once :: forall (j1 :: EffTree *) (j2 :: EffTree
                                             *) (j3 :: EffTree *) (j4 :: EffTree
                                                                           *) (u :: Graph
                                                                                      Effect).
           (Monad (Eff u j1), Monad (Eff u j2), Monad (Eff u j3),
            Monad (Eff u j4)) => ...
AaronFriel edited the summary of this revision. (Show Details)May 9 2017, 9:26 PM
AaronFriel updated the Trac tickets for this revision.

To be clear I don't object to a stop-gap approach that allows BodyStmt to work with ApplicativeDo without going all the way to Trac #10892, but the first point in my previous comment still applies: I think this will break error messages. I'm not sure what the best way to fix this is so I'll let you experiment, but we have to retain the information somehow that the original statement was a BodyStmt so that it can be printed as such in an error message.

I think this will break error messages. I'm not sure what the best way to fix this is so I'll let you experiment, but we have to retain the information somehow that the original statement was a BodyStmt so that it can be printed as such in an error message.

I'm not sure how I'd go about doing this to be honest. I just started hacking on ghc a couple days ago, and I don't even know where I'd look to see if an error message has been printed incorrectly. The errors seem to print okay to me?

-- Intentionally wrong constraint:
testCase2 :: MyApplicative m => f a -> m ()
testCase2 m1 = do
    m1
    return ()
t13649.hs:36:5: error:
    • Couldn't match type ‘f’ with ‘m’
      ‘f’ is a rigid type variable bound by
        the type signature for:
          testCase2 :: forall (m :: * -> *) (f :: * -> *) a.
                       MyApplicative m =>
                       f a -> m ()
        at t13649.hs:34:1-43
      ‘m’ is a rigid type variable bound by
        the type signature for:
          testCase2 :: forall (m :: * -> *) (f :: * -> *) a.
                       MyApplicative m =>
                       f a -> m ()
        at t13649.hs:34:1-43
      Expected type: m a
        Actual type: f a
    • m1
      In the expression:
        do m1
           return ()
      In an equation for ‘testCase2’:
          testCase2 m1
            = do m1
                 return ()
    • Relevant bindings include
        m1 :: f a (bound at t13649.hs:35:11)
        testCase2 :: f a -> m () (bound at t13649.hs:35:1)
   |
36 |     m1
   |     ^^
Failed, modules loaded: none.

I think in your test case ApplicativeDo is not transforming the statement. You need to test it with an example that gets transformed after your diff.

AaronFriel added a comment.EditedMay 11 2017, 1:16 PM

I think in your test case ApplicativeDo is not transforming the statement. You need to test it with an example that gets transformed after your diff.

I may be misunderstanding you still, please let me know if I'm not getting something. Here is my response based on what I think you're saying:

Yes the statement is being transformed by -XApplicativeDo, because previously it was not being transformed and the code generation (-ddump-ds) shows use of fmap and <*>.

The bug in Trac #12143 is related, without -XApplicativeDo a "MyMonad" constraint is inferred:

-- WITHOUT -XApplicativeDo
testCase2 :: MyApplicative m => m a -> m ()
testCase2 m1 = do
    m1
    return ()
t13649.hs:36:5: error:
    • Could not deduce (MyMonad m) arising from a do statement
      from the context: MyApplicative m
        bound by the type signature for:
                   testCase2 :: forall (m :: * -> *) a. MyApplicative m => m a -> m ()
        at t13649.hs:34:1-43
      Possible fix:
        add (MyMonad m) to the context of
          the type signature for:
            testCase2 :: forall (m :: * -> *) a. MyApplicative m => m a -> m ()
    • In a stmt of a 'do' block: m1
      In the expression:
        do m1
           return ()
      In an equation for ‘testCase2’:
          testCase2 m1
            = do m1
                 return ()
   |
36 |     m1
   |     ^^

In Trac #12143, *with* -XApplicativeDo, this is GHCI's output:

-- WITH -XApplicativeDo
Prelude> :t \m -> do { m; return True; }
\m -> do { m; return True; } :: Monad m => m a -> m Bool

With this patch, this is the output:

-- WITH -XApplicativeDo
:t \m -> do { m; return True; }
\m -> do { m; return True; } :: Functor f => f b -> f Bool

From this I believe this diff results in body statements, and the examples I gave above, being transformed by -XApplicativeDo.

AaronFriel added a comment.EditedMay 11 2017, 2:04 PM

Here's a more illustrative test case. For three cases, I will show the -ddump-rn, -ddump-ds, and :t testCase output for the function testCase:

  1. Without patch, without -XApplicativeDo
  2. Without patch, with -XApplicativeDo (shows Trac #13648)
  3. With patch, with -XApplicativeDo (shows fix to Trac #13648)
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RebindableSyntax  #-}

module Main where

import Prelude (String, print, Maybe (..), error, id)

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

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

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

class MyFail m where
    fail :: String -> m a

testCase f m1 m2 m3 = do
    a <- m1
    m2
    b <- m3
    return (f a b)

main = print "42"

Without patch, without -XApplicativeDo

/usr/bin/ghci -ddump-rn -ddump-ds -dsuppress-all ./test.hs

==================== Renamer ====================
testCase f_a11d m1_a11e m2_a11f m3_a11g
  = do { a_a11h <- m1_a11e;
         m2_a11f;
         b_a11i <- m3_a11g;
         return (f_a11d a_a11h b_a11i) }
main = print "42"

==================== Desugar (after optimization) ====================
Result size of Desugar (after optimization)
  = {terms: 100, types: 81, coercions: 0}

-- RHS size: {terms: 26, types: 36, coercions: 0}
testCase
testCase =
  \ @ a_a1gn
    @ m_a1gh
    @ b_a1gk
    @ t_a1gB
    @ t_a1gx
    $dMyMonad_a1gH
    f_a11d
    m1_a11e
    m2_a11f
    m3_a11g ->
    >>=
      $dMyMonad_a1gH
      m1_a11e
      (\ a_a11h ->
         >>
           $dMyMonad_a1gH
           m2_a11f
           (>>=
              $dMyMonad_a1gH
              m3_a11g
              (\ b_a11i -> return $dMyMonad_a1gH (f_a11d a_a11h b_a11i))))
              
*Main> :t testCase
testCase
  :: MyMonad m => (t2 -> t1 -> b) -> m t2 -> m a -> m t1 -> m b

Without patch, with -XApplicativeDo

/usr/bin/ghci -ddump-rn -ddump-ds -XApplicativeDo ./test.hs

(-dsuppress-all not used to highlight Trac #13648 bug.)

==================== Renamer ====================
Main.testCase f_a12a m1_a12b m2_a12c m3_a12d
  = do { a_a12e <- m1_a12b |
         () <- do { m2_a12c;
                    GHC.Base.return () } |
         b_a12f <- m3_a12d;
         return (f_a12a a_a12e b_a12f) }
Main.main = print "42"

==================== Desugar (after optimization) ====================
Result size of Desugar (after optimization)
  = {terms: 114, types: 99, coercions: 0}

-- RHS size: {terms: 40, types: 52, coercions: 0}
testCase
  :: forall a_a1hD (f_a1hx :: * -> *) b_a1hA t_a1hN t_a1hJ.
     (GHC.Base.Monad f_a1hx, MyMonad f_a1hx) =>
     (t_a1hJ -> t_a1hN -> b_a1hA)
     -> f_a1hx t_a1hJ -> f_a1hx a_a1hD -> f_a1hx t_a1hN -> f_a1hx b_a1hA
[LclIdX, Str=DmdType]
testCase =
  \ (@ a_a1hD)
    (@ (f_a1hx :: * -> *))
    (@ b_a1hA)
    (@ t_a1hN)
    (@ t_a1hJ)
    ($dMonad_a1oh :: GHC.Base.Monad f_a1hx)
    ($dMyMonad_a1oi :: MyMonad f_a1hx) ->
    let {
      $dMyApplicative_a1q5 :: MyApplicative f_a1hx
      [LclId, Str=DmdType]
      $dMyApplicative_a1q5 = Main.$p1MyMonad @ f_a1hx $dMyMonad_a1oi } in
    let {
      $dMyFunctor_a1hq :: MyFunctor f_a1hx
      [LclId, Str=DmdType]
      $dMyFunctor_a1hq =
        Main.$p1MyApplicative @ f_a1hx $dMyApplicative_a1q5 } in
    \ (f_a12a :: t_a1hJ -> t_a1hN -> b_a1hA)
      (m1_a12b :: f_a1hx t_a1hJ)
      (m2_a12c :: f_a1hx a_a1hD)
      (m3_a12d :: f_a1hx t_a1hN) ->
      <*>
        @ f_a1hx
        $dMyApplicative_a1q5
        @ t_a1hN
        @ b_a1hA
        (<*>
           @ f_a1hx
           $dMyApplicative_a1q5
           @ ()
           @ (t_a1hN -> b_a1hA)
           (fmap
              @ f_a1hx
              $dMyFunctor_a1hq
              @ t_a1hJ
              @ (() -> t_a1hN -> b_a1hA)
              (\ (a_a12e :: t_a1hJ) (ds_d1q9 :: ()) (b_a12f :: t_a1hN) ->
                 case ds_d1q9 of _ [Occ=Dead] { () -> f_a12a a_a12e b_a12f })
              m1_a12b)
           (>>
              @ f_a1hx
              $dMyMonad_a1oi
              @ a_a1hD
              @ ()
              m2_a12c
              (GHC.Base.return @ f_a1hx $dMonad_a1oh @ () GHC.Tuple.())))
        m3_a12d

*Main> :t testCase
testCase
  :: (MyMonad f, GHC.Base.Monad f) =>
     (t1 -> t -> b) -> f t1 -> f a -> f t -> f

Note the bug above! Instead of using the local return, it uses GHC.Base.Return! This causes a monad constraint.

With patch, with -XApplicativeDo

(/usr/local/bin/ghci -ddump-rn -ddump-ds -dsuppress-all -XApplicativeDo ./test.hs)

==================== Renamer ====================
testCase f_a1rJ m1_a1rK m2_a1rL m3_a1rM
  = do a_a1rN <- m1_a1rK | _ <- m2_a1rL | b_a1rO <- m3_a1rM
       return (f_a1rJ a_a1rN b_a1rO)
main = print "42"

==================== Desugar (after optimization) ====================
Result size of Desugar (after optimization)
  = {terms: 90, types: 85, coercions: 0, joins: 0/2}

-- RHS size: {terms: 28, types: 41, coercions: 0, joins: 0/1}
testCase
testCase
  = \ @ f_a1Js
      @ t_a1Jy
      @ t_a1JC
      @ b_a1Jv
      @ a_a1Jp
      $dMyApplicative_a1JI ->
      let {
        $dMyFunctor_a1Jj
        $dMyFunctor_a1Jj = $p1MyApplicative $dMyApplicative_a1JI } in
      \ f_a1rJ m1_a1rK m2_a1rL m3_a1rM ->
        <*>
          $dMyApplicative_a1JI
          (<*>
             $dMyApplicative_a1JI
             (fmap
                $dMyFunctor_a1Jj
                (\ a_a1rN _ b_a1rO -> f_a1rJ a_a1rN b_a1rO)
                m1_a1rK)
             m2_a1rL)
          m3_a1rM

*Main> :t testCase
testCase
  :: MyApplicative f => (t1 -> t2 -> b) -> f t1 -> f a -> f t2 -> f b

Ok, you're using a different test case now. It looks fine, but you didn't show the output of a type error message, which I think will demonstrate the problem.

bgamari requested changes to this revision.Jun 5 2017, 10:25 AM

Any update on this, @AaronFriel? Requesting changes to bump out of the review queue while @simonmar's comment is addressed.

This revision now requires changes to proceed.Jun 5 2017, 10:25 AM

Any update on this, @AaronFriel? Requesting changes to bump out of the review queue while @simonmar's comment is addressed.

No, I am working on a larger update to address more of the ApplicativeDo issues at one time. It will incorporate these changes, but without more feedback I am not sure what the issue is that @simonmar sees. If I introduced an issue in the type checker with this patch, I am not sure what I should be looking at to see it, and that may be my fault.

@AaronFriel the issue is that type error messages will display the transformed code, and not the original code that the user wrote. You'll see this if you construct an example that (a) is subject to the new transformation introduced by your patch, and (b) contains a type error that includes the transformed code. ApplicativeDo as currently implemented avoids this problem because when pretty-printed, ApplicativeStmt looks exactly like the original source code. If we turn a BodyStmt into a BindStmt, then we lose that property. Does that help?

AaronFriel added a comment.EditedJun 22 2017, 9:51 PM

Ah, I get it. So the issue isn't that it would necessarily generate the wrong types, but it would show in an error _ <- expr instead of expr? Understandable.

I misunderstood earlier and was looking for some way it would cause a program not to type check.

austin resigned from this revision.Nov 9 2017, 11:37 AM