I played with alternative implementations and attempted at implementing type-level version of this patch as suggested by @RyanGlScott.
Since `_` needs special treatment by the renamer I think we have to have some kind of special treatment for `_` in the parser too, so this implementation may not be too bad.
(alternatively I guess we could remove special treatment for `_` in the
#13088: Type operator holes don't work infix -------------------------------------+------------------------------------- Reporter: RyanGlScott | Owner: Type: bug | Status: new Priority: normal | Milestone: Component: Compiler | Version: 8.0.1 (Parser) | Keywords: | Operating System: Unknown/Multiple Architecture: | Type of failure: GHC rejects Unknown/Multiple | valid program Test Case: | Blocked By: Blocking: | Related Tickets: #13050 Differential Rev(s): | Wiki Page: -------------------------------------+------------------------------------- Originally noted in https://phabricator.haskell.org/D2910 (which fixed #13050). Currently, you can do this: Does this also work with TypeOperators? That is, you can do this: {{{#!hs {-# LANGUAGE TypeOperators #-} foo :: a `_over` b -> _over a b foo = id }}} But not this: {{{#!hs {-# LANGUAGE TypeOperators #-} foo :: a `_` b -> over a b foo = id }}} osa1 made an attempt at fixing this, and recorded his progress [https://phabricator.haskell.org/D2910#85423 here]: parser but that'd just move special cases to the renamer, so I'm not sure that's any better than the current approach)
About the type-level named infix holes: Type renamer is quite different
than term renamer (`RnTypes.hs`) and I don't understand type-checker parts of the compiler -- but I was able to made an attempt at implementing this
{{{#!diff diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 53f200f..877c243 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -608,6 +608,7 @@ type LHsAppType name = Located (HsAppType name) data HsAppType name = HsAppInfix (Located name) -- either a symbol or an id in
| HsAppPrefix (LHsType name) -- anything else, including things
+ | HsAppWild (Located (HsWildCardInfo name)) deriving instance (DataId name) => Data (HsAppType name)
instance (OutputableBndrId name) => Outputable (HsAppType name) where @@ -987,11 +988,18 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name]) splitHsAppsTy = go [] [] [] where + go :: [LHsType name] + -> [[LHsType name]] + -> [Located name] + -> [LHsAppType name] + -> ([[LHsType name]], [Located name]) go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest) = go (ty : acc) acc_non acc_sym rest go acc acc_non acc_sym (L _ (HsAppInfix op) : rest) = go [] (reverse acc : acc_non) (op : acc_sym) rest + go acc acc_non acc_sym (L l (HsAppWild (L _ wc)) : rest) + = go (L l (HsWildCardTy wc) : acc) acc_non acc_sym rest
-- Retrieve the name of the "head" of a nested type application -- somewhat like splitHsAppTys, but a little more thorough @@ -1334,14 +1342,18 @@ ppr_fun_ty ctxt_prec ty1 ty2
-------------------------- ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc -ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n +ppr_app_ty _ (HsAppInfix (L _ n)) + = pprInfixOcc n ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n)))) = pprPrefixOcc n ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar Promoted (L _ n)))) = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so -- the parser does not attach it to
backticks like (+) the
-- previous symbol -ppr_app_ty ctxt (HsAppPrefix ty) = ppr_mono_lty
ctxt ty
+ppr_app_ty ctxt (HsAppPrefix ty) + = ppr_mono_lty ctxt ty +ppr_app_ty ctxt (HsAppWild (L _ (AnonWildCard _))) + = empty -- FIXME
-------------------------- ppr_tylit :: HsTyLit -> SDoc diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index dfb6755..da4696a 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1833,6 +1833,7 @@ tyapp :: { LHsAppType RdrName } [mj AnnSimpleQuote $1] } | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2) [mj AnnSimpleQuote $1] } + | '`' '_' '`' { sL1 $1 (HsAppWild (sL1 $1 (AnonWildCard PlaceHolder))) }
atype :: { LHsType RdrName } : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index f3fcf88..9298020 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -1050,8 +1050,11 @@ collectAnonWildCards lty = go lty
gos = mconcat . map go
+ prefix_types_only :: HsAppType Name -> Maybe (LHsType Name) prefix_types_only (HsAppPrefix ty) = Just ty prefix_types_only (HsAppInfix _) = Nothing + prefix_types_only (HsAppWild (L l (AnonWildCard wc_name))) = + Just (L l (HsWildCardTy (AnonWildCard wc_name)))
collectAnonWildCardsBndrs :: [LHsTyVarBndr Name] -> [Name] collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs @@ -1646,8 +1649,9 @@ extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars -extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc -extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc +extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc +extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc +extract_app t_or_k (L _ (HsAppWild (L l wc))) acc = extract_lty t_or_k (L l (HsWildCardTy wc)) acc
extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars -> FreeKiTyVars -> RnM FreeKiTyVars }}}
Once I figure out how to do the `FIXME` part this patch may just work.
-- Ticket URL: http://ghc.haskell.org/trac/ghc/ticket/13088 GHC http://www.haskell.org/ghc/ The Glasgow Haskell Compiler