Refactor visible type application.
authorRichard Eisenberg <eir@cis.upenn.edu>
Tue, 23 Feb 2016 14:51:50 +0000 (09:51 -0500)
committerRichard Eisenberg <eir@cis.upenn.edu>
Tue, 15 Mar 2016 01:44:17 +0000 (21:44 -0400)
This replaces the old HsType and HsTypeOut constructors
with HsAppType and HsAppTypeOut, leading to some simplification.
(This refactoring addresses #11329.)

This also fixes #11456, which stumbled over HsType (which is
not an expression).

test case: ghci/scripts/T11456

[skip ci]

17 files changed:
compiler/deSugar/Coverage.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/rename/RnExpr.hs
compiler/rename/RnSource.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcRnTypes.hs
testsuite/tests/ghci/scripts/T11456.hs [new file with mode: 0644]
testsuite/tests/ghci/scripts/T11456.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T11456.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/all.T
testsuite/tests/typecheck/should_fail/T9605.stderr
testsuite/tests/typecheck/should_fail/VtaFail.stderr

index 479d8cd..c48df8a 100644 (file)
@@ -482,13 +482,15 @@ addTickLHsExprNever (L pos e0) = do
 -- general heuristic: expressions which do not denote values are good
 -- break points
 isGoodBreakExpr :: HsExpr Id -> Bool
-isGoodBreakExpr (HsApp {})     = True
-isGoodBreakExpr (OpApp {})     = True
-isGoodBreakExpr _other         = False
+isGoodBreakExpr (HsApp {})        = True
+isGoodBreakExpr (HsAppTypeOut {}) = True
+isGoodBreakExpr (OpApp {})        = True
+isGoodBreakExpr _other            = False
 
 isCallSite :: HsExpr Id -> Bool
-isCallSite HsApp{}  = True
-isCallSite OpApp{}  = True
+isCallSite HsApp{}        = True
+isCallSite HsAppTypeOut{} = True
+isCallSite OpApp{}        = True
 isCallSite _ = False
 
 addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
@@ -518,13 +520,10 @@ addTickHsExpr e@(HsOverLabel _)  = return e
 addTickHsExpr e@(HsLit _)        = return e
 addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
 addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1) e2'
-  -- This might be a type application. Then don't put a tick around e2,
-  -- or dsExpr won't recognize it as a type application any more (#11329).
-  -- It doesn't make sense to put a tick on a type anyways.
-  where e2'
-          | isLHsTypeExpr e2 = return e2
-          | otherwise        = addTickLHsExpr e2
+addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1)
+                                                (addTickLHsExpr      e2)
+addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
+                                                        (return ty)
 
 addTickHsExpr (OpApp e1 e2 fix e3) =
         liftM4 OpApp
index 2320ab4..59c8c4d 100644 (file)
@@ -234,10 +234,11 @@ dsExpr (HsLamCase arg matches)
        ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
 
 dsExpr e@(HsApp fun arg)
+  = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
+
+dsExpr (HsAppTypeOut e _)
     -- ignore type arguments here; they're in the wrappers instead at this point
-  | isLHsTypeExpr arg = dsLExpr fun
-  | otherwise         = mkCoreAppDs (text "HsApp" <+> ppr e)
-                        <$> dsLExpr fun <*>  dsLExpr arg
+  = dsLExpr e
 
 
 {-
@@ -730,16 +731,10 @@ dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"
 dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"
 dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
 dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
-dsExpr (HsType        {})  = panic "dsExpr:HsType" -- removed by typechecker
+dsExpr (HsAppType     {})  = panic "dsExpr:HsAppType" -- removed by typechecker
 dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
 dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
 
--- Normally handled in HsApp case, but a GHC API user might try to desugar
--- an HsTypeOut, since it is an HsExpr in a typechecked module after all.
--- (Such as ghci itself, in #11456.) So improve the error message slightly.
-dsExpr (HsTypeOut {})
-  = panic "dsExpr: tried to desugar a naked type application argument (HsTypeOut)"
-
 ------------------------------
 dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
 dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
index 7a8de3c..4ed3431 100644 (file)
@@ -309,8 +309,8 @@ repDataDefn tc bndrs opt_tys
        }
 
 repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
-          -> LHsType Name
-          -> DsM (Core TH.DecQ)
+           -> LHsType Name
+           -> DsM (Core TH.DecQ)
 repSynDecl tc bndrs ty
   = do { ty1 <- repLTy ty
        ; repTySyn tc bndrs ty1 }
index dd850c4..7f09726 100644 (file)
@@ -9,6 +9,7 @@
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
 
 -- | Abstract Haskell syntax for expressions.
 module HsExpr where
@@ -203,6 +204,16 @@ data HsExpr id
 
   | HsApp     (LHsExpr id) (LHsExpr id) -- ^ Application
 
+  | HsAppType (LHsExpr id) (LHsWcType id) -- ^ Visible type application
+       --
+       -- Explicit type argument; e.g  f @Int x y
+       -- NB: Has wildcards, but no implicit quantification
+       --
+       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',
+
+  | HsAppTypeOut (LHsExpr id) (LHsWcType Name) -- just for pretty-printing
+
+
   -- | Operator applications:
   -- NB Bracketed ops such as (+) come out as Vars.
 
@@ -545,14 +556,6 @@ data HsExpr id
   -- For details on above see note [Api annotations] in ApiAnnotation
   | ELazyPat    (LHsExpr id) -- ~ pattern
 
-  -- | Use for type application in expressions.
-  -- 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsType      (LHsWcType id) -- Explicit type argument; e.g  f @Int x y
-                               -- NB: Has wildcards, but no implicit quant.
-
-  | HsTypeOut   (LHsWcType Name)  -- just for pretty-printing
 
   ---------------------------------------
   -- Finally, HsWrap appears only in typechecker output
@@ -663,10 +666,12 @@ isQuietHsExpr :: HsExpr id -> Bool
 -- Parentheses do display something, but it gives little info and
 -- if we go deeper when we go inside them then we get ugly things
 -- like (...)
-isQuietHsExpr (HsPar _) = True
+isQuietHsExpr (HsPar _)          = True
 -- applications don't display anything themselves
-isQuietHsExpr (HsApp _ _) = True
-isQuietHsExpr (OpApp _ _ _ _) = True
+isQuietHsExpr (HsApp _ _)        = True
+isQuietHsExpr (HsAppType _ _)    = True
+isQuietHsExpr (HsAppTypeOut _ _) = True
+isQuietHsExpr (OpApp _ _ _ _)    = True
 isQuietHsExpr _ = False
 
 pprBinds :: (OutputableBndr idL, OutputableBndr idR)
@@ -689,12 +694,9 @@ ppr_expr (HsPar e)        = parens (ppr_lexpr e)
 ppr_expr (HsCoreAnn _ (StringLiteral _ s) e)
   = vcat [text "HsCoreAnn" <+> ftext s, ppr_lexpr e]
 
-ppr_expr (HsApp e1 e2)
-  = let (fun, args) = collect_args e1 [e2] in
-    hang (ppr_lexpr fun) 2 (sep (map pprParendLExpr args))
-  where
-    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
-    collect_args fun args = (fun, args)
+ppr_expr e@(HsApp {})        = ppr_apps e []
+ppr_expr e@(HsAppType {})    = ppr_apps e []
+ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
 
 ppr_expr (OpApp e1 op _ e2)
   = case unLoc op of
@@ -815,11 +817,6 @@ ppr_expr (HsWrap co_fn e)
   = pprHsWrapper co_fn (\parens -> if parens then pprParendExpr e
                                              else pprExpr       e)
 
-ppr_expr (HsType (HsWC { hswc_body = ty }))
-  = char '@' <> pprParendHsType (unLoc ty)
-ppr_expr (HsTypeOut (HsWC { hswc_body = ty }))
-  = char '@' <> pprParendHsType (unLoc ty)
-
 ppr_expr (HsSpliceE s)         = pprSplice s
 ppr_expr (HsBracket b)         = pprHsBracket b
 ppr_expr (HsRnBracketOut e []) = ppr e
@@ -868,6 +865,26 @@ ppr_expr (HsArrForm op _ args)
          4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
 ppr_expr (HsRecFld f) = ppr f
 
+-- We must tiresomely make the "id" parameter to the LHsWcType existential
+-- because it's different in the HsAppType case and the HsAppTypeOut case
+data LHsWcTypeX = forall id. OutputableBndr id => LHsWcTypeX (LHsWcType id)
+
+ppr_apps :: OutputableBndr id
+         => HsExpr id
+         -> [Either (LHsExpr id) LHsWcTypeX]
+         -> SDoc
+ppr_apps (HsApp (L _ fun) arg)        args
+  = ppr_apps fun (Left arg : args)
+ppr_apps (HsAppType (L _ fun) arg)    args
+  = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps (HsAppTypeOut (L _ fun) arg) args
+  = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
+  where
+    pp (Left arg)                             = pprParendLExpr arg
+    pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
+      = char '@' <> pprParendHsType arg
+
 pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
 pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
   = ppr (src,(n1,n2),(n3,n4))
@@ -923,8 +940,6 @@ hsExprNeedsParens (HsTcBracketOut {}) = False
 hsExprNeedsParens (HsDo sc _ _)
        | isListCompExpr sc            = False
 hsExprNeedsParens (HsRecFld{})        = False
-hsExprNeedsParens (HsType {})         = False
-hsExprNeedsParens (HsTypeOut {})      = False
 hsExprNeedsParens _ = True
 
 
index cb2da5c..8ac7e24 100644 (file)
@@ -20,13 +20,13 @@ which deal with the instantiated versions are located elsewhere:
 
 module HsUtils(
   -- Terms
-  mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
+  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkSimpleHsAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
   mkHsDictLet, mkHsLams,
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
-  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr,
+  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
 
   nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
   nlHsIntLit, nlHsVarApps,
@@ -169,6 +169,12 @@ mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
 mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 
+mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
+mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
+
+mkHsAppTypeOut :: LHsExpr Id -> LHsWcType Name -> LHsExpr Id
+mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
+
 mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
         where
@@ -458,21 +464,6 @@ nlHsFunTy a b           = noLoc (HsFunTy a b)
 nlHsTyConApp :: name -> [LHsType name] -> LHsType name
 nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 
--- | Extract a type argument from an HsExpr, with the list of wildcards in
--- the type
-isLHsTypeExpr_maybe :: LHsExpr name -> Maybe (LHsWcType name)
-isLHsTypeExpr_maybe (L _ (HsPar e))       = isLHsTypeExpr_maybe e
-isLHsTypeExpr_maybe (L _ (HsType ty))     = Just ty
-  -- the HsTypeOut case is ill-typed. We never need it here anyway.
-isLHsTypeExpr_maybe _                     = Nothing
-
--- | Is an expression a visible type application?
-isLHsTypeExpr :: LHsExpr name -> Bool
-isLHsTypeExpr (L _ (HsPar e))     = isLHsTypeExpr e
-isLHsTypeExpr (L _ (HsType _))    = True
-isLHsTypeExpr (L _ (HsTypeOut _)) = True
-isLHsTypeExpr _                   = False
-
 {-
 Tuples.  All these functions are *pre-typechecker* because they lack
 types on the tuple.
@@ -1132,4 +1123,3 @@ lPatImplicits = hs_lpat
                                                                      (unLoc fld)
                                                           pat_explicit = maybe True (i<) (rec_dotdot fs)]
     details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2
-
index dead15b..a640bcb 100644 (file)
@@ -2241,10 +2241,12 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
                                          }
 
 fexp    :: { LHsExpr RdrName }
-        : fexp aexp                             { sLL $1 $> $ HsApp $1 $2 }
-        | 'static' aexp                         {% ams (sLL $1 $> $ HsStatic $2)
-                                                       [mj AnnStatic $1] }
-        | aexp                                  { $1 }
+        : fexp aexp                  { sLL $1 $> $ HsApp $1 $2 }
+        | fexp TYPEAPP atype         {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
+                                            [mj AnnAt $2] }
+        | 'static' aexp              {% ams (sLL $1 $> $ HsStatic $2)
+                                            [mj AnnStatic $1] }
+        | aexp                       { $1 }
 
 aexp    :: { LHsExpr RdrName }
         : qvar '@' aexp         {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] }
@@ -2252,7 +2254,6 @@ aexp    :: { LHsExpr RdrName }
             -- Note [Lexing type applications] in Lexer.x
 
         | '~' aexp              {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }
-        | TYPEAPP atype         {% ams (sLL $1 $> $ HsType (mkHsWildCardBndrs $2)) [mj AnnAt $1] }
         | aexp1                 { $1 }
 
 aexp1   :: { LHsExpr RdrName }
index 510543c..de03b8d 100644 (file)
@@ -146,6 +146,11 @@ rnExpr (HsApp fun arg)
        ; (arg',fvArg) <- rnLExpr arg
        ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
 
+rnExpr (HsAppType fun arg)
+  = do { (fun',fvFun) <- rnLExpr fun
+       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
+       ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }
+
 rnExpr (OpApp e1 op  _ e2)
   = do  { (e1', fv_e1) <- rnLExpr e1
         ; (e2', fv_e2) <- rnLExpr e2
@@ -303,10 +308,6 @@ rnExpr (HsMultiIf _ty alts)
        -- ; return (HsMultiIf ty alts', fvs) }
        ; return (HsMultiIf placeHolderType alts', fvs) }
 
-rnExpr (HsType ty)
-  = do { (ty', fvT) <- rnHsWcType HsTypeCtx ty
-       ; return (HsType ty', fvT) }
-
 rnExpr (ArithSeq _ _ seq)
   = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
        ; (new_seq, fvs) <- rnArithSeq seq
@@ -1754,6 +1755,7 @@ isReturnApp (L _ (HsApp f arg))
   | otherwise = Nothing
  where
   is_return (L _ (HsPar e)) = is_return e
+  is_return (L _ (HsAppType e _)) = is_return e
   is_return (L _ (HsVar (L _ r))) = r == returnMName || r == pureAName
        -- TODO: I don't know how to get this right for rebindable syntax
   is_return _ = False
index 67afee7..df729dc 100644 (file)
@@ -1024,6 +1024,7 @@ validRuleLhs foralls lhs
 
     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
+    check (HsAppType e _)                 = checkl e
     check (HsVar (L _ v)) | v `notElem` foralls = Nothing
     check other                           = Just other  -- Failure
 
index a2b6bfc..23d0de9 100644 (file)
@@ -73,6 +73,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Data.Function
 import Data.List
+import Data.Either
 import qualified Data.Set as Set
 
 {-
@@ -163,9 +164,8 @@ tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
 tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
 tcExpr (HsUnboundVar v)   res_ty = tcUnboundId v res_ty
 
-tcExpr (HsApp e1 e2) res_ty
-  = do { (wrap, fun, args) <- tcApp Nothing e1 [e2] res_ty
-       ; return (mkHsWrap wrap $ unLoc $ foldl mkHsApp fun args) }
+tcExpr e@(HsApp {})     res_ty = tcApp1 e res_ty
+tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
 
 tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit
                                  ; tcWrapResult e (HsLit lit) lit_ty res_ty }
@@ -257,11 +257,6 @@ tcExpr e@(ExprWithTySig expr sig_ty) res_ty
        ; let expr'' = ExprWithTySigOut expr' sig_ty
        ; tcWrapResult e expr'' poly_ty res_ty }
 
-tcExpr (HsType ty) _
-  = failWithTc (sep [ text "Type argument used outside of a function argument:"
-                    , ppr ty ])
-
-
 {-
 Note [Type-checking overloaded labels]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -404,9 +399,9 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
 
   | otherwise
   = do { traceTc "Non Application rule" (ppr op)
-       ; (wrap, op', [arg1', arg2'])
+       ; (wrap, op', [Left arg1', Left arg2'])
            <- tcApp (Just $ mk_op_msg op)
-                     op [arg1, arg2] res_ty
+                     op [Left arg1, Left arg2] res_ty
        ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
 
 -- Right sections, equivalent to \ x -> x `op` expr, or
@@ -1059,10 +1054,22 @@ arithSeqEltType (Just fl) res_ty
 ************************************************************************
 -}
 
+type LHsExprArgIn  = Either (LHsExpr Name) (LHsWcType Name)
+type LHsExprArgOut = Either (LHsExpr TcId) (LHsWcType Name)
+
+tcApp1 :: HsExpr Name  -- either HsApp or HsAppType
+       -> ExpRhoType -> TcM (HsExpr TcId)
+tcApp1 e res_ty
+  = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty
+       ; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) }
+  where
+    mk_hs_app f (Left a)  = mkHsApp f a
+    mk_hs_app f (Right a) = mkHsAppTypeOut f a
+
 tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
                      -- or leave out to get exactly that message
-      -> LHsExpr Name -> [LHsExpr Name] -- Function and args
-      -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
+      -> LHsExpr Name -> [LHsExprArgIn] -- Function and args
+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
            -- (wrap, fun, args). For an ordinary function application,
            -- these should be assembled as (wrap (fun args)).
            -- But OpApp is slightly different, so that's why the caller
@@ -1071,21 +1078,24 @@ tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
 tcApp m_herald orig_fun orig_args res_ty
   = go orig_fun orig_args
   where
-    go (L _ (HsPar e))     args = go e  args
-    go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
+    go :: LHsExpr Name -> [LHsExprArgIn]
+       -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
+    go (L _ (HsPar e))       args = go e  args
+    go (L _ (HsApp e1 e2))   args = go e1 (Left e2:args)
+    go (L _ (HsAppType e t)) args = go e  (Right t:args)
 
     go (L loc (HsVar (L _ fun))) args
       | fun `hasKey` tagToEnumKey
-      , count (not . isLHsTypeExpr) args == 1
+      , count isLeft args == 1
       = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
            ; return (wrap, expr, args) }
 
       | fun `hasKey` seqIdKey
-      , count (not . isLHsTypeExpr) args == 2
+      , count isLeft args == 2
       = do { (wrap, expr, args) <- tcSeq loc fun args res_ty
            ; return (wrap, expr, args) }
 
-    go (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg : _)
+    go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _)
       | Just sig_ty <- obviousSig arg
       = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
            ; sel_name  <- disambiguateSelector lbl sig_tc_ty
@@ -1104,11 +1114,14 @@ tcApp m_herald orig_fun orig_args res_ty
                 -- up to call that function
            ; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
                          tcSubTypeDS_NC_O orig GenSigCtxt
-                           (Just $ foldl mkHsApp fun args)
+                           (Just $ foldl mk_hs_app fun args)
                            actual_res_ty res_ty
 
            ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
 
+    mk_hs_app f (Left a)  = mkHsApp f a
+    mk_hs_app f (Right a) = mkHsAppType f a
+
 mk_app_msg :: LHsExpr Name -> SDoc
 mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun)
                      , text "is applied to"]
@@ -1145,9 +1158,9 @@ tcInferFun fun
 tcArgs :: LHsExpr Name   -- ^ The function itself (for err msgs only)
        -> TcSigmaType    -- ^ the (uninstantiated) type of the function
        -> CtOrigin       -- ^ the origin for the function's type
-       -> [LHsExpr Name] -- ^ the args
+       -> [LHsExprArgIn] -- ^ the args
        -> SDoc           -- ^ the herald for matchActualFunTys
-       -> TcM (HsWrapper, [LHsExpr TcId], TcSigmaType)
+       -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
           -- ^ (a wrapper for the function, the tc'd args, result type)
 tcArgs fun orig_fun_ty fun_orig orig_args herald
   = go [] 1 orig_fun_ty orig_args
@@ -1156,8 +1169,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
 
     go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
 
-    go acc_args n fun_ty (arg:args)
-      | Just hs_ty_arg <- isLHsTypeExpr_maybe arg
+    go acc_args n fun_ty (Right hs_ty_arg:args)
       = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
                -- wrap1 :: fun_ty "->" upsilon_ty
            ; case tcSplitForAllTy_maybe upsilon_ty of
@@ -1172,11 +1184,11 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
                    -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
                     ; let inst_wrap = mkWpTyApps [ty_arg]
                     ; return ( inner_wrap <.> inst_wrap <.> wrap1
-                             , L (getLoc arg) (HsTypeOut hs_ty_arg) : args'
+                             , Right hs_ty_arg : args'
                              , res_ty ) }
                _ -> ty_app_err upsilon_ty hs_ty_arg }
 
-      | otherwise   -- not a type application.
+    go acc_args n fun_ty (Left arg : args)
       = do { (wrap, [arg_ty], res_ty)
                <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty
                                         acc_args orig_arity
@@ -1186,7 +1198,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
                <- go (arg_ty : acc_args) (n+1) res_ty args
                -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
            ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty <.> wrap
-                    , arg' : args'
+                    , Left arg' : args'
                     , inner_res_ty ) }
 
     ty_app_err ty arg
@@ -1650,16 +1662,15 @@ the users that complain.
 
 -}
 
-tcSeq :: SrcSpan -> Name -> [LHsExpr Name]
-      -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
+tcSeq :: SrcSpan -> Name -> [LHsExprArgIn]
+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
 -- (seq e1 e2) :: res_ty
 -- We need a special typing rule because res_ty can be unboxed
 -- See Note [Typing rule for seq]
 tcSeq loc fun_name args res_ty
   = do  { fun <- tcLookupId fun_name
         ; (arg1_ty, args1) <- case args of
-            (ty_arg_expr1 : args1)
-              | Just hs_ty_arg1 <- isLHsTypeExpr_maybe ty_arg_expr1
+            (Right hs_ty_arg1 : args1)
               -> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind
                     ; return (ty_arg1, args1) }
 
@@ -1667,47 +1678,41 @@ tcSeq loc fun_name args res_ty
                     ; return (arg_ty1, args) }
 
         ; (arg1, arg2, arg2_exp_ty) <- case args1 of
-            [ty_arg_expr2, term_arg1, term_arg2]
-              | Just hs_ty_arg2 <- isLHsTypeExpr_maybe ty_arg_expr2
+            [Right hs_ty_arg2, Left term_arg1, Left term_arg2]
               -> do { rr_ty <- newFlexiTyVarTy runtimeRepTy
                     ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE rr_ty)
                                    -- see Note [Typing rule for seq]
                     ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty
                     ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
-            [term_arg1, term_arg2] -> return (term_arg1, term_arg2, res_ty)
-            _ -> too_many_args
+            [Left term_arg1, Left term_arg2]
+              -> return (term_arg1, term_arg2, res_ty)
+            _ -> too_many_args "seq" args
 
         ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
         ; arg2' <- tcMonoExpr arg2 arg2_exp_ty
         ; res_ty <- readExpType res_ty  -- by now, it's surely filled in
         ; let fun'    = L loc (HsWrap ty_args (HsVar (L loc fun)))
               ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
-        ; return (idHsWrapper, fun', [arg1', arg2']) }
-  where
-    too_many_args :: TcM a
-    too_many_args
-      = failWith $
-        hang (text "Too many type arguments to seq:")
-           2 (sep (map pprParendLExpr args))
-tcTagToEnum :: SrcSpan -> Name -> [LHsExpr Name] -> ExpRhoType
-            -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
+        ; return (idHsWrapper, fun', [Left arg1', Left arg2']) }
+
+tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
+            -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
 -- tagToEnum# :: forall a. Int# -> a
 -- See Note [tagToEnum#]   Urgh!
 tcTagToEnum loc fun_name args res_ty
   = do { fun <- tcLookupId fun_name
 
        ; arg <- case args of
-           [ty_arg_expr, term_arg]
-             | Just hs_ty_arg <- isLHsTypeExpr_maybe ty_arg_expr
+           [Right hs_ty_arg, Left term_arg]
              -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
                    ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg res_ty
                      -- other than influencing res_ty, we just
                      -- don't care about a type arg passed in.
                      -- So drop the evidence.
                    ; return term_arg }
-           [term_arg] -> do { _ <- expTypeToType res_ty
-                            ; return term_arg }
-           _          -> too_many_args
+           [Left term_arg] -> do { _ <- expTypeToType res_ty
+                                 ; return term_arg }
+           _          -> too_many_args "tagToEnum#" args
 
        ; res_ty <- readExpType res_ty
        ; ty'    <- zonkTcType res_ty
@@ -1731,7 +1736,7 @@ tcTagToEnum loc fun_name args res_ty
        ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
              rep_ty = mkTyConApp rep_tc rep_args
 
-       ; return (mkWpCastR (mkTcSymCo coi), fun', [arg']) }
+       ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }
                  -- coi is a Representational coercion
   where
     doc1 = vcat [ text "Specify the type by giving a type signature"
@@ -1744,11 +1749,15 @@ tcTagToEnum loc fun_name args res_ty
                <+> text "at type" <+> ppr ty)
            2 what
 
-    too_many_args :: TcM a
-    too_many_args
-      = failWith $
-        hang (text "Too many type arguments to tagToEnum#:")
-           2 (sep (map pprParendLExpr args))
+too_many_args :: String -> [LHsExprArgIn] -> TcM a
+too_many_args fun args
+  = failWith $
+    hang (text "Too many type arguments to" <+> text fun <> colon)
+       2 (sep (map pp args))
+  where
+    pp (Left e)                             = pprParendLExpr e
+    pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t
+
 
 {-
 ************************************************************************
index d7d23a2..6e35a2b 100644 (file)
@@ -609,6 +609,11 @@ zonkExpr env (HsApp e1 e2)
        new_e2 <- zonkLExpr env e2
        return (HsApp new_e1 new_e2)
 
+zonkExpr env (HsAppTypeOut e t)
+  = do new_e <- zonkLExpr env e
+       return (HsAppTypeOut new_e t)
+       -- NB: the type is an HsType; can't zonk that!
+
 zonkExpr _ e@(HsRnBracketOut _ _)
   = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
 
@@ -772,9 +777,6 @@ zonkExpr env (HsWrap co_fn expr)
 zonkExpr _ (HsUnboundVar v)
   = return (HsUnboundVar v)
 
-  -- nothing to do here. The payload is an LHsType, not a Type.
-zonkExpr _ e@(HsTypeOut {}) = return e
-
 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
 
 -------------------------------------------------------------------------
index c642397..309bb97 100644 (file)
@@ -2816,6 +2816,8 @@ exprCtOrigin (HsLit {})         = Shouldn'tHappenOrigin "concrete literal"
 exprCtOrigin (HsLam matches)    = matchesCtOrigin matches
 exprCtOrigin (HsLamCase _ ms)   = matchesCtOrigin ms
 exprCtOrigin (HsApp (L _ e1) _) = exprCtOrigin e1
+exprCtOrigin (HsAppType (L _ e1) _) = exprCtOrigin e1
+exprCtOrigin (HsAppTypeOut {})      = panic "exprCtOrigin HsAppTypeOut"
 exprCtOrigin (OpApp _ (L _ op) _ _) = exprCtOrigin op
 exprCtOrigin (NegApp (L _ e) _) = exprCtOrigin e
 exprCtOrigin (HsPar (L _ e))    = exprCtOrigin e
@@ -2853,8 +2855,6 @@ exprCtOrigin EWildPat           = panic "exprCtOrigin EWildPat"
 exprCtOrigin (EAsPat {})        = panic "exprCtOrigin EAsPat"
 exprCtOrigin (EViewPat {})      = panic "exprCtOrigin EViewPat"
 exprCtOrigin (ELazyPat {})      = panic "exprCtOrigin ELazyPat"
-exprCtOrigin (HsType {})        = Shouldn'tHappenOrigin "type application"
-exprCtOrigin (HsTypeOut {})     = panic "exprCtOrigin HsTypeOut"
 exprCtOrigin (HsWrap {})        = panic "exprCtOrigin HsWrap"
 
 -- | Extract a suitable CtOrigin from a MatchGroup
diff --git a/testsuite/tests/ghci/scripts/T11456.hs b/testsuite/tests/ghci/scripts/T11456.hs
new file mode 100644 (file)
index 0000000..736ffcb
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+
+module T11456 where
+
+a = show @Int
diff --git a/testsuite/tests/ghci/scripts/T11456.script b/testsuite/tests/ghci/scripts/T11456.script
new file mode 100644 (file)
index 0000000..0408aac
--- /dev/null
@@ -0,0 +1,2 @@
+:set +c
+:load T11456
diff --git a/testsuite/tests/ghci/scripts/T11456.stdout b/testsuite/tests/ghci/scripts/T11456.stdout
new file mode 100644 (file)
index 0000000..14a67ed
--- /dev/null
@@ -0,0 +1 @@
+Collecting type info for 1 module(s) ... 
index 87be4f1..62326a2 100755 (executable)
@@ -245,3 +245,4 @@ test('T11266', check_stdout(lambda *args: 1), ghci_script, ['T11266.script'])
 
 test('T11389', req_interp, run_command, ['$MAKE -s --no-print-directory T11389'])
 test('T11524a', normal, ghci_script, ['T11524a.script'])
+test('T11456', normal, ghci_script, ['T11456.script'])
index 479899c..38da1c4 100644 (file)
@@ -1,11 +1,11 @@
 
-T9605.hs:7:6:
-    Couldn't match type ‘Bool’ with ‘m Bool’
-    Expected type: t0 -> m Bool
-      Actual type: t0 -> Bool
-    The function ‘f1’ is applied to one argument,
-    its type is ‘m0 Bool’,
-    it is specialized to ‘t0 -> Bool’
-    In the expression: f1 undefined
-    In an equation for ‘f2’: f2 = f1 undefined
-    Relevant bindings include f2 :: m Bool (bound at T9605.hs:7:1)
+T9605.hs:7:6: error:
+    • Couldn't match type ‘Bool’ with ‘m Bool’
+      Expected type: t1 -> m Bool
+        Actual type: t1 -> Bool
+    • The function ‘f1’ is applied to one argument,
+      its type is ‘m0 Bool’,
+      it is specialized to ‘t1 -> Bool’
+      In the expression: f1 undefined
+      In an equation for ‘f2’: f2 = f1 undefined
+    • Relevant bindings include f2 :: m Bool (bound at T9605.hs:7:1)
index 6d11a4a..ff15398 100644 (file)
@@ -13,7 +13,7 @@ VtaFail.hs:12:26: error:
           answer_constraint_fail = addOne @Bool 5
 
 VtaFail.hs:14:17: error:
-    • Cannot apply expression of type ‘t0 -> t0
+    • Cannot apply expression of type ‘t1 -> t1
       to a visible type argument ‘Int’
     • In the expression: (\ x -> x) @Int 12
       In an equation for ‘answer_lambda’: