Fix deriving Ord when RebindableSyntax is enabled
authorAndrew Farmer <anfarmer@fb.com>
Sat, 21 May 2016 16:38:47 +0000 (18:38 +0200)
committerBen Gamari <ben@smart-cactus.org>
Sat, 21 May 2016 17:10:59 +0000 (19:10 +0200)
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
compiler/typecheck/TcGenDeriv.hs
testsuite/tests/rebindable/T12080.hs [new file with mode: 0644]
testsuite/tests/rebindable/all.T

index ee34773..6b90f00 100644 (file)
@@ -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)
 
index 15f0480..4157b02 100644 (file)
@@ -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 (file)
index 0000000..5413ed0
--- /dev/null
@@ -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
index b42f884..f1737e9 100644 (file)
@@ -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, [''])