Commit bfd93f90 authored by Ryan Scott's avatar Ryan Scott

Fix #15792 by not reifying invisible arguments in AppTys

The `reifyType` function in `TcSplice` is carefully designed
to avoid reifying visible arguments to `TyConApp`s. However, the same
care was not given towards the `AppTy` case, which lead to #15792.

This patch changes to the `AppTy` case of `reifyType` so that it
consults the kind of the function type to determine which of the
argument types are invisible (and therefore should be dropped) during
reification. This required crafting a variant of `tyConArgFlags`,
which I dubbed `appTyArgFlags`, that accept an arbitrary function
`Type` instead of a `TyCon`.

Test Plan: make test TEST=T15792

Reviewers: goldfire, bgamari, simonpj

Reviewed By: simonpj

Subscribers: simonpj, rwbarton, carter

GHC Trac Issues: #15792

Differential Revision:
parent bb835c96
......@@ -1743,7 +1743,23 @@ reifyType ty@(ForAllTy {}) = reify_for_all ty
reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) }
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
reifyType ty@(AppTy {}) = do
let (ty_head, ty_args) = splitAppTys ty
ty_head' <- reifyType ty_head
ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args)
pure $ mkThAppTs ty_head' ty_args'
-- Make sure to filter out any invisible arguments. For instance, if you
-- reify the following:
-- newtype T (f :: forall a. a -> Type) = MkT (f Bool)
-- Then you should receive back `f Bool`, not `f Type Bool`, since the
-- `Type` argument is invisible (#15792).
filter_out_invisible_args :: Type -> [Type] -> [Type]
filter_out_invisible_args ty_head ty_args =
filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)
reifyType ty@(FunTy t1 t2)
| isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
| otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
......@@ -63,7 +63,8 @@ module Type (
stripCoercionTy, splitCoercionType_maybe,
splitPiTysInvisible, filterOutInvisibleTypes, filterOutInferredTypes,
partitionInvisibleTypes, partitionInvisibles, tyConArgFlags,
partitionInvisibleTypes, partitionInvisibles,
tyConArgFlags, appTyArgFlags,
modifyJoinResTy, setJoinResTy,
......@@ -1573,8 +1574,9 @@ partitionInvisibles = partitionWith pick_invis
pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing
| otherwise = Right thing
-- | Given a 'TyCon' and a list of argument types, determine each argument's
-- visibility ('Inferred', 'Specified', or 'Required').
-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is
-- applied, determine each argument's visibility
-- ('Inferred', 'Specified', or 'Required').
-- Wrinkle: consider the following scenario:
......@@ -1588,7 +1590,26 @@ partitionInvisibles = partitionWith pick_invis
-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again,
-- and @Q@ is visible.
tyConArgFlags :: TyCon -> [Type] -> [ArgFlag]
tyConArgFlags tc = go emptyTCvSubst (tyConKind tc)
tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc)
-- | Given a 'Type' and a list of argument types to which the 'Type' is
-- applied, determine each argument's visibility
-- ('Inferred', 'Specified', or 'Required').
-- Most of the time, the arguments will be 'Required', but not always. Consider
-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is
-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely
-- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy,
-- since @f Type Bool@ would be represented in Core using 'AppTy's.
-- (See also Trac #15792).
appTyArgFlags :: Type -> [Type] -> [ArgFlag]
appTyArgFlags ty = fun_kind_arg_flags (typeKind ty)
-- | Given a function kind and a list of argument types (where each argument's
-- kind aligns with the corresponding position in the argument kind), determine
-- each argument's visibility ('Inferred', 'Specified', or 'Required').
fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag]
fun_kind_arg_flags = go emptyTCvSubst
go _ _ [] = []
go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys)
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module T15792 where
import Data.Kind
import Language.Haskell.TH hiding (Type)
import System.IO
newtype T (f :: forall a. a -> Type) = MkT (f Bool)
$(pure [])
$(do info <- reify ''T
runIO $ hPutStrLn stderr $ pprint info
pure [])
newtype T15792.T (f_0 :: forall (a_1 :: *) . a_1 -> *)
= T15792.MkT (f_0 GHC.Types.Bool)
......@@ -441,3 +441,4 @@ test('TH_recover_warns', normal, compile, ['-v0 -ddump-splices -dsuppress-unique
test('T15738', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T15783', normal, multimod_compile,
['T15783A', '-v0 ' + config.ghc_th_way_flags])
test('T15792', normal, compile, ['-v0 -dsuppress-uniques'])
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