Commit 6ee831f2 authored by Ryan Scott's avatar Ryan Scott

Fix #14888 by adding more special cases for ArrowT

Summary:
There were previously some situations where `(->)` would
not be desugared or reified as `ArrowT`, leading to various oddities
such as those observed in #14888. We now uniformly treat `(->)` as
`ArrowT` in Template Haskell–world by checking for any tycon that
has the same name as `(->)`, and converting that to `ArrowT`.

Test Plan: make test TEST=T14888

Reviewers: goldfire, bgamari, simonpj

Reviewed By: goldfire, simonpj

Subscribers: simonpj, rwbarton, thomie, carter

GHC Trac Issues: #14888

Differential Revision: https://phabricator.haskell.org/D4466
parent 3d252037
......@@ -994,6 +994,7 @@ repTy ty@(HsQualTy {}) = repForall ty
repTy (HsTyVar _ (L _ n))
| isLiftedTypeKindTyConName n = repTStar
| n `hasKey` constraintKindTyConKey = repTConstraint
| n `hasKey` funTyConKey = repArrowTyCon
| isTvOcc occ = do tv1 <- lookupOcc n
repTvar tv1
| isDataOcc occ = do tc1 <- lookupOcc n
......
......@@ -1881,6 +1881,7 @@ reify_tc_app tc tys
| isTupleTyCon tc = if isPromotedDataCon tc
then TH.PromotedTupleT arity
else TH.TupleT arity
| tc `hasKey` funTyConKey = TH.ArrowT
| tc `hasKey` listTyConKey = TH.ListT
| tc `hasKey` nilDataConKey = TH.PromotedNilT
| tc `hasKey` consDataConKey = TH.PromotedConsT
......
{-# LANGUAGE TemplateHaskell #-}
module T14888 where
import Language.Haskell.TH
foo :: $([t| (->) Bool Bool |])
foo x = x
class Functor' f where
fmap' :: (a -> b) -> f a -> f b
instance Functor' ((->) r) where
fmap' = (.)
$(return [])
functor'Instances :: String
functor'Instances = $(reify ''Functor' >>= stringE . pprint)
T14888.hs:6:10-30: Splicing type
[t| (->) Bool Bool |] ======> Bool -> Bool
T14888.hs:15:3-11: Splicing declarations return [] ======>
T14888.hs:18:23-59: Splicing expression
reify ''Functor' >>= stringE . pprint
======>
"class T14888.Functor' (f_0 :: * -> *)
where T14888.fmap' :: forall (f_0 :: * ->
*) . T14888.Functor' f_0 =>
forall (a_1 :: *) (b_2 :: *) . (a_1 -> b_2) -> f_0 a_1 -> f_0 b_2
instance T14888.Functor' ((->) r_3 :: * -> *)"
......@@ -403,3 +403,5 @@ test('T14838', [], multimod_compile,
['T14838.hs', '-v0 -Wincomplete-patterns ' + config.ghc_th_way_flags])
test('T14817', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T14843', normal, compile, ['-v0'])
test('T14888', normal, compile,
['-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags])
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