[GHC] #13088: Type operator holes don't work infix

GHC ghc-devs at haskell.org
Sun Jan 8 17:51:46 UTC 2017


#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]:

 > 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
 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
 backticks
 >    | HsAppPrefix (LHsType name)      -- anything else, including things
 like (+)
 > +  | 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
 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


More information about the ghc-tickets mailing list