summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Expr.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs8
-rw-r--r--compiler/GHC/Tc/Solver/Canonical.hs6
-rw-r--r--compiler/GHC/Tc/Solver/Types.hs8
-rw-r--r--compiler/GHC/Tc/Types/EvTerm.hs5
-rw-r--r--compiler/GHC/Tc/Types/Evidence.hs65
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs54
-rw-r--r--testsuite/tests/rebindable/T19918.hs72
-rw-r--r--testsuite/tests/rebindable/T19918.stderr2
-rw-r--r--testsuite/tests/rebindable/T19918.stdout16
-rw-r--r--testsuite/tests/rebindable/T20126.hs13
-rw-r--r--testsuite/tests/rebindable/T20126.stderr6
-rw-r--r--testsuite/tests/rebindable/all.T2
13 files changed, 222 insertions, 43 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 24b8247b32..011a527d53 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1050,13 +1050,15 @@ names 'getField' and 'setField' are whatever in-scope names they are.
-}
-- See Note [Rebindable syntax and HsExpansion] just above.
-data HsExpansion a b
- = HsExpanded a b
+data HsExpansion orig expanded
+ = HsExpanded orig expanded
deriving Data
-- | Just print the original expression (the @a@).
instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
- ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
+ ppr (HsExpanded orig expanded)
+ = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+ (ppr orig)
{-
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index d04944661d..e898b74be5 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -185,10 +185,10 @@ tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syn
; let r_ty = mkTyVarTy r_tv
; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
(TcRnUnknownMessage $ mkPlainError noHints $ text "Predicate type of `ifThenElse' depends on result type")
- ; (pred', fun')
- <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])
- (mkCheckExpType r_ty) $ \ _ _ ->
- tcCheckMonoExpr pred pred_ty
+ ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun
+ (map synKnownType [pred_ty, r_ty, r_ty])
+ (mkCheckExpType r_ty) $ \ _ _ ->
+ tcCheckMonoExpr pred pred_ty
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index a17b7f0204..162ef60cbc 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -153,7 +153,7 @@ canClassNC ev cls tys
| isWanted ev
, Just ip_name <- isCallStackPred cls tys
- , OccurrenceOf func <- ctLocOrigin loc
+ , isPushCallStackOrigin orig
-- If we're given a CallStack constraint that arose from a function
-- call, we need to push the current call-site onto the stack instead
-- of solving it directly from a given.
@@ -170,7 +170,8 @@ canClassNC ev cls tys
-- Then we solve the wanted by pushing the call-site
-- onto the newly emitted CallStack
- ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)
+ ; let ev_cs = EvCsPushCall (callStackOriginFS orig)
+ (ctLocSpan loc) (ctEvExpr new_ev)
; solveCallStack ev ev_cs
; canClass new_ev cls tys
@@ -184,6 +185,7 @@ canClassNC ev cls tys
where
has_scs cls = not (null (classSCTheta cls))
loc = ctEvLoc ev
+ orig = ctLocOrigin loc
pred = ctEvPred ev
fds = classHasFds cls
diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs
index 0ff06e21c1..1636bbede4 100644
--- a/compiler/GHC/Tc/Solver/Types.hs
+++ b/compiler/GHC/Tc/Solver/Types.hs
@@ -138,7 +138,7 @@ findDict m loc cls tys
= Nothing
| Just {} <- isCallStackPred cls tys
- , OccurrenceOf {} <- ctLocOrigin loc
+ , isPushCallStackOrigin (ctLocOrigin loc)
= Nothing -- See Note [Solving CallStack constraints]
| otherwise
@@ -219,13 +219,15 @@ constraints, but it seemed more direct to deal with the lookup.
Note [Solving CallStack constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence.
+
Suppose f :: HasCallStack => blah. Then
* Each call to 'f' gives rise to
[W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f
with a CtOrigin that says "OccurrenceOf f".
Remember that HasCallStack is just shorthand for
- IP "callStack CallStack
+ IP "callStack" CallStack
See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by
@@ -239,7 +241,7 @@ Suppose f :: HasCallStack => blah. Then
So we must be careful /not/ to solve 's1' from the Givens. Again,
we ensure this by arranging that findDict always misses when looking
-up souch constraints.
+up such constraints.
-}
{- *********************************************************************
diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs
index ad380ec0a2..e55a930774 100644
--- a/compiler/GHC/Tc/Types/EvTerm.hs
+++ b/compiler/GHC/Tc/Types/EvTerm.hs
@@ -21,7 +21,6 @@ import GHC.Core.Make
import GHC.Core.Utils
import GHC.Types.SrcLoc
-import GHC.Types.Name
import GHC.Types.TyThing
-- Used with Opt_DeferTypeErrors
@@ -71,5 +70,5 @@ evCallStack cs = do
return (pushCS nameExpr locExpr (Cast tm ip_co))
case cs of
- EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
- EvCsEmpty -> return emptyCS
+ EvCsPushCall fs loc tm -> mkPush fs loc tm
+ EvCsEmpty -> return emptyCS
diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs
index 4bda7e5354..7dd8dfef67 100644
--- a/compiler/GHC/Tc/Types/Evidence.hs
+++ b/compiler/GHC/Tc/Types/Evidence.hs
@@ -77,7 +77,6 @@ import GHC.Builtin.Names
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Core.Predicate
-import GHC.Types.Name
import GHC.Data.Pair
import GHC.Types.Basic
@@ -90,6 +89,8 @@ import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Data.Bag
+import GHC.Data.FastString
+
import qualified Data.Data as Data
import GHC.Types.SrcLoc
import Data.IORef( IORef )
@@ -654,9 +655,14 @@ data EvTypeable
data EvCallStack
-- See Note [Overview of implicit CallStacks]
= EvCsEmpty
- | EvCsPushCall Name RealSrcSpan EvExpr
- -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at
- -- @loc@, in a calling context @stk@.
+ | EvCsPushCall
+ FastString -- Usually the name of the function being called
+ -- but can also be "the literal 42"
+ -- or "an if-then-else expression", etc
+ RealSrcSpan -- Location of the call
+ EvExpr -- Rest of the stack
+ -- ^ @EvCsPushCall origin loc stk@ represents a call from @origin@,
+ -- occurring at @loc@, in a calling context @stk@.
deriving Data.Data
{-
@@ -740,7 +746,7 @@ Conclusion: a new wanted coercion variable should be made mutable.
Note [Overview of implicit CallStacks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations)
The goal of CallStack evidence terms is to reify locations
@@ -753,8 +759,11 @@ to constraints of type GHC.Stack.Types.HasCallStack, an alias
Implicit parameters of type GHC.Stack.Types.CallStack (the name is not
important) are solved in three steps:
-1. Occurrences of CallStack IPs are solved directly from the given IP,
- just like a regular IP. For example, the occurrence of `?stk` in
+1. Explicit, user-written occurrences of `?stk :: CallStack`
+ which have IPOccOrigin, are solved directly from the given IP,
+ just like a regular IP; see GHC.Tc.Solver.Interact.interactDict.
+
+ For example, the occurrence of `?stk` in
error :: (?stk :: CallStack) => String -> a
error s = raise (ErrorCall (s ++ prettyCallStack ?stk))
@@ -765,30 +774,42 @@ important) are solved in three steps:
append the current call-site to it. For example, consider a
call to the callstack-aware `error` above.
- undefined :: (?stk :: CallStack) => a
- undefined = error "undefined!"
+ foo :: (?stk :: CallStack) => a
+ foo = error "undefined!"
Here we want to take the given `?stk` and append the current
call-site, before passing it to `error`. In essence, we want to
- rewrite `error "undefined!"` to
+ rewrite `foo "undefined!"` to
- let ?stk = pushCallStack <error's location> ?stk
- in error "undefined!"
+ let ?stk = pushCallStack <foo's location> ?stk
+ in foo "undefined!"
- We achieve this effect by emitting a NEW wanted
+ We achieve this as follows:
- [W] d :: IP "stk" CallStack
+ * At a call of foo :: (?stk :: CallStack) => blah
+ we emit a Wanted
+ [W] d1 : IP "stk" CallStack
+ with CtOrigin = OccurrenceOf "foo"
- from which we build the evidence term
+ * We /solve/ this constraint, in GHC.Tc.Solver.Canonical.canClassNC
+ by emitting a NEW Wanted
+ [W] d2 :: IP "stk" CallStack
+ with CtOrigin = IPOccOrigin
- EvCsPushCall "error" <error's location> (EvId d)
+ and solve d1 = EvCsPushCall "foo" <foo's location> (EvId d1)
- that we use to solve the call to `error`. The new wanted `d` will
- then be solved per rule (1), ie as a regular IP.
+ * The new Wanted, for `d2` will be solved per rule (1), ie as a regular IP.
- (see GHC.Tc.Solver.Interact.interactDict)
+3. We use the predicate isPushCallStackOrigin to identify whether we
+ want to do (1) solve directly, or (2) push and then solve directly.
+ Key point (see #19918): the CtOrigin where we want to push an item on the
+ call stack can include IfThenElseOrigin etc, when RebindableSyntax is
+ involved. See the defn of fun_orig in GHC.Tc.Gen.App.tcInstFun; it is
+ this CtOrigin that is pinned on the constraints generated by functions
+ in the "expansion" for rebindable syntax. c.f. GHC.Rename.Expr
+ Note [Handling overloaded and rebindable constructs]
-3. We default any insoluble CallStacks to the empty CallStack. Suppose
+4. We default any insoluble CallStacks to the empty CallStack. Suppose
`undefined` did not request a CallStack, ie
undefinedNoStk :: a
@@ -1042,8 +1063,8 @@ instance Outputable EvTerm where
instance Outputable EvCallStack where
ppr EvCsEmpty
= text "[]"
- ppr (EvCsPushCall name loc tm)
- = ppr (name,loc) <+> text ":" <+> ppr tm
+ ppr (EvCsPushCall orig loc tm)
+ = ppr (orig,loc) <+> text ":" <+> ppr tm
instance Outputable EvTypeable where
ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 371093a183..e66a83f5bb 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -18,11 +18,15 @@ module GHC.Tc.Types.Origin (
-- CtOrigin
CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
isVisibleOrigin, toInvisibleOrigin,
- pprCtOrigin, isGivenOrigin
+ pprCtOrigin, isGivenOrigin,
+
+ -- CtOrigin and CallStack
+ isPushCallStackOrigin, callStackOriginFS
) where
import GHC.Prelude
+import GHC.Utils.Misc (HasCallStack)
import GHC.Tc.Utils.TcType
@@ -432,7 +436,6 @@ data CtOrigin
| MCompOrigin -- Arising from a monad comprehension
| MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a
-- monad comprehension
- | IfOrigin -- Arising from an if statement
| ProcOrigin -- Arising from a proc expression
| AnnOrigin -- An annotation
@@ -450,6 +453,7 @@ data CtOrigin
| TypeHoleOrigin OccName -- from a type hole (partial type signature)
| PatCheckOrigin -- normalisation of a type during pattern-match checking
| ListOrigin -- An overloaded list
+ | IfThenElseOrigin -- An if-then-else expression
| BracketOrigin -- An overloaded quotation bracket
| StaticOrigin -- A static form
| Shouldn'tHappenOrigin String
@@ -521,7 +525,7 @@ exprCtOrigin (SectionR _ _ _) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum"
exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
-exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression"
+exprCtOrigin (HsIf {}) = IfThenElseOrigin
exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e
exprCtOrigin (HsDo {}) = DoOrigin
@@ -639,7 +643,7 @@ pprCtOrigin simple_origin
= ctoHerald <+> pprCtO simple_origin
-- | Short one-liners
-pprCtO :: CtOrigin -> SDoc
+pprCtO :: HasCallStack => CtOrigin -> SDoc
pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)]
pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)]
pprCtO AppOrigin = text "an application"
@@ -651,7 +655,6 @@ pprCtO ExprSigOrigin = text "an expression type signature"
pprCtO PatSigOrigin = text "a pattern type signature"
pprCtO PatOrigin = text "a pattern"
pprCtO ViewPatOrigin = text "a view pattern"
-pprCtO IfOrigin = text "an if expression"
pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)]
pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)]
pprCtO SectionOrigin = text "an operator section"
@@ -672,8 +675,47 @@ pprCtO (ExprHoleOrigin occ) = text "a use of" <+> quotes (ppr occ)
pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ)
pprCtO PatCheckOrigin = text "a pattern-match completeness check"
pprCtO ListOrigin = text "an overloaded list"
+pprCtO IfThenElseOrigin = text "an if-then-else expression"
pprCtO StaticOrigin = text "a static form"
pprCtO NonLinearPatternOrigin = text "a non-linear pattern"
pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]
pprCtO BracketOrigin = text "a quotation bracket"
-pprCtO _ = panic "pprCtOrigin"
+
+-- These ones are handled by pprCtOrigin, but we nevertheless sometimes
+-- get here via callStackOriginFS, when doing ambiguity checks
+-- A bit silly, but no great harm
+pprCtO (GivenOrigin {}) = text "a given constraint"
+pprCtO (SpecPragOrigin {}) = text "a SPECIALISE pragma"
+pprCtO (FunDepOrigin1 {}) = text "a functional dependency"
+pprCtO (FunDepOrigin2 {}) = text "a functional dependency"
+pprCtO (TypeEqOrigin {}) = text "a type equality"
+pprCtO (KindEqOrigin {}) = text "a kind equality"
+pprCtO (DerivOriginDC {}) = text "a deriving clause"
+pprCtO (DerivOriginCoerce {}) = text "a derived method"
+pprCtO (DoPatOrigin {}) = text "a do statement"
+pprCtO (MCompPatOrigin {}) = text "a monad comprehension pattern"
+pprCtO (Shouldn'tHappenOrigin note) = text note
+pprCtO (ProvCtxtOrigin {}) = text "a provided constraint"
+pprCtO (InstProvidedOrigin {}) = text "a provided constraint"
+pprCtO (CycleBreakerOrigin orig) = pprCtO orig
+
+{- *********************************************************************
+* *
+ CallStacks and CtOrigin
+
+ See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
+* *
+********************************************************************* -}
+
+isPushCallStackOrigin :: CtOrigin -> Bool
+-- Do we want to solve this IP constraint directly (return False)
+-- or push the call site (return True)
+-- See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence
+isPushCallStackOrigin (IPOccOrigin {}) = False
+isPushCallStackOrigin _ = True
+
+
+callStackOriginFS :: CtOrigin -> FastString
+-- This is the string that appears in the CallStack
+callStackOriginFS (OccurrenceOf fun) = occNameFS (getOccName fun)
+callStackOriginFS orig = mkFastString (showSDocUnsafe (pprCtO orig))
diff --git a/testsuite/tests/rebindable/T19918.hs b/testsuite/tests/rebindable/T19918.hs
new file mode 100644
index 0000000000..1c708921ea
--- /dev/null
+++ b/testsuite/tests/rebindable/T19918.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE QualifiedDo #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE TypeApplications #-}
+module Main where
+
+import Control.Monad (when, return)
+import Data.Bool
+import Data.Function (($))
+import Debug.Trace (traceShow)
+import GHC.Stack
+import GHC.Types (Symbol)
+import System.IO (IO, print)
+import qualified Control.Monad
+
+fromString :: HasCallStack => a -> CallStack
+fromString _ = callStack
+
+fromInteger :: HasCallStack => a -> CallStack
+fromInteger _ = callStack
+
+fromRational :: HasCallStack => a -> CallStack
+fromRational _ = callStack
+
+fromListN :: HasCallStack => len -> a -> CallStack
+fromListN _len _ = callStack
+
+fromLabel :: forall (_lbl::Symbol). HasCallStack => CallStack
+fromLabel = callStack
+
+ifThenElse :: HasCallStack => Bool -> a -> a -> CallStack
+ifThenElse cond _ok _ko | cond = callStack
+ | otherwise = callStack
+
+(>>) :: HasCallStack => a -> b -> CallStack
+(>>) _a _b = callStack
+
+negate :: HasCallStack => a -> CallStack
+negate _a = callStack
+
+(==) :: HasCallStack => a -> b -> Bool
+(==) _a _b = traceShow callStack True
+
+main :: IO ()
+main = Control.Monad.do
+
+ -- These come out on stdout
+ print $ fromString "str"
+ print $ "str"
+ print $ fromLabel @"lbl"
+ print $ #lbl
+ print $ fromInteger 42
+ print $ 42
+ print $ fromRational 4.2
+ print $ 4.2
+ print $ fromListN () []
+ print $ []
+ print $ ifThenElse True () ()
+ print $ if True then () else ()
+ print $ negate 42
+ print $ -42
+ print $ () >> ()
+ print $ do { (); () }
+
+ -- These two come out in stderr, from traceShow
+ when (42 == 42) $ return ()
+ case 42 of
+ 42 -> return ()
+ return ()
diff --git a/testsuite/tests/rebindable/T19918.stderr b/testsuite/tests/rebindable/T19918.stderr
new file mode 100644
index 0000000000..21b9a4173f
--- /dev/null
+++ b/testsuite/tests/rebindable/T19918.stderr
@@ -0,0 +1,2 @@
+[("==",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 69, srcLocStartCol = 12, srcLocEndLine = 69, srcLocEndCol = 14})]
+[("the literal `42'",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 71, srcLocStartCol = 5, srcLocEndLine = 71, srcLocEndCol = 7})]
diff --git a/testsuite/tests/rebindable/T19918.stdout b/testsuite/tests/rebindable/T19918.stdout
new file mode 100644
index 0000000000..bb0c06f620
--- /dev/null
+++ b/testsuite/tests/rebindable/T19918.stdout
@@ -0,0 +1,16 @@
+[("fromString",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 51, srcLocStartCol = 11, srcLocEndLine = 51, srcLocEndCol = 21})]
+[("the literal `\"str\"'",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 52, srcLocStartCol = 11, srcLocEndLine = 52, srcLocEndCol = 16})]
+[("fromLabel",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 53, srcLocStartCol = 11, srcLocEndLine = 53, srcLocEndCol = 20})]
+[("the overloaded label `#lbl'",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 54, srcLocStartCol = 11, srcLocEndLine = 54, srcLocEndCol = 15})]
+[("fromInteger",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 55, srcLocStartCol = 11, srcLocEndLine = 55, srcLocEndCol = 22})]
+[("the literal `42'",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 56, srcLocStartCol = 11, srcLocEndLine = 56, srcLocEndCol = 13})]
+[("fromRational",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 57, srcLocStartCol = 11, srcLocEndLine = 57, srcLocEndCol = 23})]
+[("the literal `4.2'",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 58, srcLocStartCol = 11, srcLocEndLine = 58, srcLocEndCol = 14})]
+[("fromListN",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 59, srcLocStartCol = 11, srcLocEndLine = 59, srcLocEndCol = 20})]
+[("an overloaded list",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 60, srcLocStartCol = 11, srcLocEndLine = 60, srcLocEndCol = 13})]
+[("ifThenElse",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 61, srcLocStartCol = 11, srcLocEndLine = 61, srcLocEndCol = 21})]
+[("an if-then-else expression",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 62, srcLocStartCol = 11, srcLocEndLine = 62, srcLocEndCol = 34})]
+[("negate",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 63, srcLocStartCol = 11, srcLocEndLine = 63, srcLocEndCol = 17})]
+[("a use of syntactic negation",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 64, srcLocStartCol = 11, srcLocEndLine = 64, srcLocEndCol = 14})]
+[(">>",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 65, srcLocStartCol = 14, srcLocEndLine = 65, srcLocEndCol = 16})]
+[("a do statement",SrcLoc {srcLocPackage = "main", srcLocModule = "Main", srcLocFile = "T19918.hs", srcLocStartLine = 66, srcLocStartCol = 16, srcLocEndLine = 66, srcLocEndCol = 18})]
diff --git a/testsuite/tests/rebindable/T20126.hs b/testsuite/tests/rebindable/T20126.hs
new file mode 100644
index 0000000000..9416de2e4b
--- /dev/null
+++ b/testsuite/tests/rebindable/T20126.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE RebindableSyntax #-}
+
+module Foo where
+
+import Prelude( Bool(..) )
+
+class Wombat a
+
+ifThenElse :: Wombat a => Bool -> a -> a -> a
+ifThenElse _ ok _ = ok
+
+foo :: ()
+foo = if True then () else ()
diff --git a/testsuite/tests/rebindable/T20126.stderr b/testsuite/tests/rebindable/T20126.stderr
new file mode 100644
index 0000000000..420f723431
--- /dev/null
+++ b/testsuite/tests/rebindable/T20126.stderr
@@ -0,0 +1,6 @@
+
+T20126.hs:13:7: error:
+ • No instance for (Wombat ())
+ arising from an if-then-else expression
+ • In the expression: if True then () else ()
+ In an equation for ‘foo’: foo = if True then () else ()
diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T
index c58efa5db0..b5123102e9 100644
--- a/testsuite/tests/rebindable/all.T
+++ b/testsuite/tests/rebindable/all.T
@@ -40,3 +40,5 @@ test('T11216A', normal, compile, [''])
test('T12080', normal, compile, [''])
test('T14670', expect_broken(14670), compile, [''])
test('T19167', normal, compile, [''])
+test('T19918', normal, compile_and_run, [''])
+test('T20126', normal, compile_fail, [''])
View Lorry Controller Status