From 527ed7246a35fe8bab89c7c582084cd20661018a Mon Sep 17 00:00:00 2001
From: Andrew Farmer <anfarmer@fb.com>
Date: Sat, 21 May 2016 18:38:47 +0200
Subject: 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
---
 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(-)
 create mode 100644 testsuite/tests/rebindable/T12080.hs

diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index ee34773e1d..6b90f001b0 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 15f0480880..4157b02b72 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 0000000000..5413ed060c
--- /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 b42f884055..f1737e9603 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, [''])
-- 
cgit v1.2.1