Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Tobias Decking
GHC
Commits
517908fc
Commit
517908fc
authored
Dec 17, 2014
by
Simon Peyton Jones
Browse files
Fix egregious bug in the new canonicalisation code for AppTy
Fixes Trac #9892. Must form part of 7.10.1
parent
2469f854
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/typecheck/TcCanonical.hs
View file @
517908fc
...
...
@@ -626,7 +626,9 @@ try_decompose_app :: CtEvidence -> EqRel
-- so can't turn it into an application if it
-- doesn't look like one already
-- See Note [Canonicalising type applications]
try_decompose_app
ev
NomEq
ty1
ty2
=
try_decompose_nom_app
ev
ty1
ty2
try_decompose_app
ev
NomEq
ty1
ty2
=
try_decompose_nom_app
ev
ty1
ty2
try_decompose_app
ev
ReprEq
ty1
ty2
|
ty1
`
eqType
`
ty2
-- See Note [AppTy reflexivity check]
=
canEqReflexive
ev
ReprEq
ty1
...
...
@@ -654,17 +656,17 @@ try_decompose_nom_app ev ty1 ty2
=
canEqNC
ev
NomEq
ty1
ty2
where
-- do_decompose is like xCtEvidence, but recurses
-- to try_decompose_app to decompose a chain of AppTys
-- to try_decompose_
nom_
app to decompose a chain of AppTys
do_decompose
s1
t1
s2
t2
|
CtDerived
{
ctev_loc
=
loc
}
<-
ev
=
do
{
emitNewDerived
loc
(
mkTcEqPred
t1
t2
)
;
try_decompose_nom_app
ev
s1
s2
}
;
canEqNC
ev
NomEq
s1
s2
}
|
CtWanted
{
ctev_evar
=
evar
,
ctev_loc
=
loc
}
<-
ev
=
do
{
ev_s
<-
newWantedEvVarNC
loc
(
mkTcEqPred
s1
s2
)
;
co_t
<-
unifyWanted
loc
Nominal
t1
t2
;
let
co
=
mkTcAppCo
(
ctEvCoercion
ev_s
)
co_t
;
setEvBind
evar
(
EvCoercion
co
)
;
try_decompose_nom_app
ev_s
s1
s2
}
;
canEqNC
ev_s
NomEq
s1
s2
}
|
CtGiven
{
ctev_evtm
=
ev_tm
,
ctev_loc
=
loc
}
<-
ev
=
do
{
let
co
=
evTermCoercion
ev_tm
co_s
=
mkTcLRCo
CLeft
co
...
...
@@ -672,7 +674,7 @@ try_decompose_nom_app ev ty1 ty2
;
evar_s
<-
newGivenEvVar
loc
(
mkTcEqPred
s1
s2
,
EvCoercion
co_s
)
;
evar_t
<-
newGivenEvVar
loc
(
mkTcEqPred
t1
t2
,
EvCoercion
co_t
)
;
emitWorkNC
[
evar_t
]
;
try_decompose_nom_app
evar_s
s1
s2
}
;
canEqNC
evar_s
NomEq
s1
s2
}
|
otherwise
-- Can't happen
=
error
"try_decompose_app"
...
...
testsuite/tests/typecheck/should_compile/T9892.hs
0 → 100644
View file @
517908fc
{-# LANGUAGE UndecidableInstances #-}
module
T9892
where
import
Control.Applicative
import
Control.Category
import
Prelude
hiding
((
.
),
id
)
newtype
FocusingPlus
w
k
s
a
=
FocusingPlus
{
unfocusingPlus
::
k
(
s
,
w
)
a
}
instance
Functor
(
k
(
s
,
w
))
=>
Functor
(
FocusingPlus
w
k
s
)
where
fmap
f
(
FocusingPlus
as
)
=
FocusingPlus
(
fmap
f
as
)
instance
Applicative
(
k
(
s
,
w
))
=>
Applicative
(
FocusingPlus
w
k
s
)
where
pure
=
FocusingPlus
.
pure
FocusingPlus
kf
<*>
FocusingPlus
ka
=
FocusingPlus
(
kf
<*>
ka
)
testsuite/tests/typecheck/should_compile/all.T
View file @
517908fc
...
...
@@ -436,3 +436,5 @@ test('T9497b', normal, compile, ['-fdefer-typed-holes -fno-warn-typed-holes'])
test
('
T9497c
',
normal
,
compile
,
['
-fdefer-type-errors -fno-warn-typed-holes
'])
test
('
T7643
',
normal
,
compile
,
[''])
test
('
T9834
',
normal
,
compile
,
[''])
test
('
T9892
',
normal
,
compile
,
[''])
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment