Commit 527ed724 authored by Andrew Farmer's avatar Andrew Farmer Committed by Ben Gamari

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:

GHC Trac Issues: #12080
parent da3c1ebb
......@@ -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)
......@@ -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
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
{-# 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
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment