[commit: ghc] master: Fix deriving Ord when RebindableSyntax is enabled (527ed72)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/527ed7246a35fe8bab89c7c582084cd20661018a/ghc

>---------------------------------------------------------------

commit 527ed7246a35fe8bab89c7c582084cd20661018a
Author: Andrew Farmer <anfarmer at fb.com>
Date:   Sat May 21 18:38:47 2016 +0200

    Fix deriving Ord when RebindableSyntax is enabled
    
    Deriving clauses (Ord especially) generated if-expressions with nlHsIf
    which were subject to RebindableSyntax. This changes nlHsIf to generate
    concrete if-expressions.
    
    There was also an error about calling tagToEnum# at a polymorphic type,
    which is not allowed. Fixing nlHsIf didn't fix this for some reason, so
    I generated a type ascription around the call to tagToEnum#. Not sure
    why the typechecker could not figure this out.
    
    Test Plan: Added a test, ran validate.
    
    Reviewers: simonpj, simonmar, austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2247
    
    GHC Trac Issues: #12080


>---------------------------------------------------------------

527ed7246a35fe8bab89c7c582084cd20661018a
 compiler/hsSyn/HsUtils.hs            |  7 ++++++-
 compiler/typecheck/TcGenDeriv.hs     | 10 ++++++----
 testsuite/tests/rebindable/T12080.hs | 16 ++++++++++++++++
 testsuite/tests/rebindable/all.T     |  1 +
 4 files changed, 29 insertions(+), 5 deletions(-)

diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index ee34773..6b90f00 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -450,7 +450,12 @@ nlList   :: [LHsExpr RdrName] -> LHsExpr RdrName
 
 nlHsLam match          = noLoc (HsLam (mkMatchGroup Generated [match]))
 nlHsPar e              = noLoc (HsPar e)
-nlHsIf cond true false = noLoc (mkHsIf cond true false)
+
+-- Note [Rebindable nlHsIf]
+-- nlHsIf should generate if-expressions which are NOT subject to
+-- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
+nlHsIf cond true false = noLoc (HsIf Nothing cond true false)
+
 nlHsCase expr matches  = noLoc (HsCase expr (mkMatchGroup Generated matches))
 nlList exprs           = noLoc (ExplicitList placeHolderType Nothing exprs)
 
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 15f0480..4157b02 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -524,11 +524,13 @@ unliftedCompare :: RdrName -> RdrName
                 -> LHsExpr RdrName
 -- Return (if a < b then lt else if a == b then eq else gt)
 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
-  = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
+  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
                         -- Test (<) first, not (==), because the latter
                         -- is true less often, so putting it first would
                         -- mean more tests (dynamically)
-        nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
+        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
+  where
+    ascribeBool e = nlExprWithTySig e (toLHsSigWcType boolTy)
 
 nlConWildPat :: DataCon -> LPat RdrName
 -- The pattern (K {})
@@ -2189,8 +2191,8 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
                   `nlExprWithTySig` toLHsSigWcType to_ty
 
 
-    nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
-    nlExprWithTySig e s = noLoc (ExprWithTySig e s)
+nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
+nlExprWithTySig e s = noLoc (ExprWithTySig e s)
 
 mkCoerceClassMethEqn :: Class   -- the class being derived
                      -> [TyVar] -- the tvs in the instance head
diff --git a/testsuite/tests/rebindable/T12080.hs b/testsuite/tests/rebindable/T12080.hs
new file mode 100644
index 0000000..5413ed0
--- /dev/null
+++ b/testsuite/tests/rebindable/T12080.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RebindableSyntax #-}
+
+import Prelude
+
+class IfThenElse a b where
+  ifThenElse :: a -> b -> b -> b
+
+instance IfThenElse Bool b where
+  ifThenElse c x y = if c then x else y
+
+data Foo = Foo | Bar | Baz deriving (Eq, Ord)
+
+main :: IO ()
+main = print $ Foo < Bar
diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T
index b42f884..f1737e9 100644
--- a/testsuite/tests/rebindable/all.T
+++ b/testsuite/tests/rebindable/all.T
@@ -32,3 +32,4 @@ test('T4851', normal, compile, [''])
 test('T5908', normal, compile, [''])
 test('T10112', normal, compile, [''])
 test('T11216', [expect_broken(11216)], compile, [''])
+test('T12080', normal, compile, [''])