[commit: ghc] master: Fix #15792 by not reifying invisible arguments in AppTys (bfd93f9)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/bfd93f90b6c63edf2790356e95feddf9898ec888/ghc

>---------------------------------------------------------------

commit bfd93f90b6c63edf2790356e95feddf9898ec888
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Wed Oct 24 07:03:40 2018 -0400

    Fix #15792 by not reifying invisible arguments in AppTys
    
    Summary:
    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: https://phabricator.haskell.org/D5252


>---------------------------------------------------------------

bfd93f90b6c63edf2790356e95feddf9898ec888
 compiler/typecheck/TcSplice.hs   | 18 +++++++++++++++++-
 compiler/types/Type.hs           | 29 +++++++++++++++++++++++++----
 testsuite/tests/th/T15792.hs     | 16 ++++++++++++++++
 testsuite/tests/th/T15792.stderr |  2 ++
 testsuite/tests/th/all.T         |  1 +
 5 files changed, 61 insertions(+), 5 deletions(-)

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 8f05225..c5886d3 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -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'
+  where
+    -- 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)
+                   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) }
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 9012815..1846525 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -63,7 +63,8 @@ module Type (
         stripCoercionTy, splitCoercionType_maybe,
 
         splitPiTysInvisible, filterOutInvisibleTypes, filterOutInferredTypes,
-        partitionInvisibleTypes, partitionInvisibles, tyConArgFlags,
+        partitionInvisibleTypes, partitionInvisibles,
+        tyConArgFlags, appTyArgFlags,
         synTyConResKind,
 
         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 at . 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
   where
     go _ _ [] = []
     go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys)
diff --git a/testsuite/tests/th/T15792.hs b/testsuite/tests/th/T15792.hs
new file mode 100644
index 0000000..2567fb5
--- /dev/null
+++ b/testsuite/tests/th/T15792.hs
@@ -0,0 +1,16 @@
+{-# 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 [])
diff --git a/testsuite/tests/th/T15792.stderr b/testsuite/tests/th/T15792.stderr
new file mode 100644
index 0000000..c13f7ba
--- /dev/null
+++ b/testsuite/tests/th/T15792.stderr
@@ -0,0 +1,2 @@
+newtype T15792.T (f_0 :: forall (a_1 :: *) . a_1 -> *)
+  = T15792.MkT (f_0 GHC.Types.Bool)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index d10523c..75ec5db 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -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'])