Commit ff923954 authored by Alan Zimmerman's avatar Alan Zimmerman

Make HsAppsType contents Located

An HsAppInfix can carry a qconop/varop preceded by a SIMPLEQUOTE as a
Located RdrName.

In this case AnnSimpleQuote is attached to the Located HsAppType.

    | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ HsAppInfix $2)
                                           [mj AnnSimpleQuote $1] }
    | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ HsAppInfix $2)
                                           [mj AnnSimpleQuote $1] }

This patch changes

    data HsType name
      ...
      | HsAppsTy [HsAppType name]

to

    data HsType name
      ...
      | HsAppsTy [LHsAppType name]

so that the annotation is not discarded when it reaches the ParsedSource
parent aa7fb9a6
......@@ -1227,17 +1227,17 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy s (fsLit s)
cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName
cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
= L (combineSrcSpans loc1 loc2) $
HsAppsTy (t1' ++ [HsAppInfix (noLoc op)] ++ t2')
HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
where
t1' | L _ (HsAppsTy t1s) <- t1
= t1s
| otherwise
= [HsAppPrefix t1]
= [noLoc $ HsAppPrefix t1]
t2' | L _ (HsAppsTy t2s) <- t2
= t2s
| otherwise
= [HsAppPrefix t2]
= [noLoc $ HsAppPrefix t2]
cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
cvtKind = cvtTypeKind "kind"
......
......@@ -27,7 +27,7 @@ module HsTypes (
HsContext, LHsContext,
HsTyLit(..),
HsIPName(..), hsIPNameFS,
HsAppType(..),
HsAppType(..),LHsAppType,
LBangType, BangType,
HsSrcBang(..), HsImplBang(..),
......@@ -387,7 +387,7 @@ data HsType name
-- For details on above see note [Api annotations] in ApiAnnotation
| HsAppsTy [HsAppType name] -- Used only before renaming,
| HsAppsTy [LHsAppType name] -- Used only before renaming,
-- Note [HsAppsTy]
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
......@@ -542,6 +542,9 @@ data HsWildCardInfo name
deriving (Typeable)
deriving instance (DataId name) => Data (HsWildCardInfo name)
type LHsAppType name = Located (HsAppType name)
-- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSimpleQuote'
data HsAppType name
= HsAppInfix (Located name) -- either a symbol or an id in backticks
| HsAppPrefix (LHsType name) -- anything else, including things like (+)
......@@ -996,9 +999,9 @@ splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
splitHsFunType other = ([], other)
ignoreParens :: LHsType name -> LHsType name
ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
ignoreParens (L _ (HsAppsTy [HsAppPrefix ty])) = ignoreParens ty
ignoreParens ty = ty
ignoreParens (L _ (HsParTy ty)) = ignoreParens ty
ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty
ignoreParens ty = ty
{-
************************************************************************
......@@ -1108,9 +1111,9 @@ pprParendHsType ty = ppr_mono_ty TyConPrec ty
-- Before printing a type, remove outermost HsParTy parens
prepare :: HsType name -> HsType name
prepare (HsParTy ty) = prepare (unLoc ty)
prepare (HsAppsTy [HsAppPrefix (L _ ty)]) = prepare ty
prepare ty = ty
prepare (HsParTy ty) = prepare (unLoc ty)
prepare (HsAppsTy [L _ (HsAppPrefix (L _ ty))]) = prepare ty
prepare ty = ty
ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
......@@ -1150,7 +1153,7 @@ ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
ppr_mono_ty ctxt_prec (HsAppsTy tys)
= maybeParen ctxt_prec TyConPrec $
hsep (map (ppr_app_ty TopPrec) tys)
hsep (map (ppr_app_ty TopPrec . unLoc) tys)
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen ctxt_prec TyConPrec $
......
......@@ -968,7 +968,9 @@ hsConDeclsBinders cons = go id cons
L loc (ConDeclGADT { con_names = names
, con_type = HsIB { hsib_body = res_ty}}) ->
case tau of
L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _res_ty)
L _ (HsFunTy
(L _ (HsAppsTy
[L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
-> record_gadt flds
L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
-> record_gadt flds
......@@ -1109,7 +1111,7 @@ lPatImplicits = hs_lpat
-- | Retrieves the head of an HsAppsTy, if this can be done unambiguously,
-- without consulting fixities.
getAppsTyHead_maybe :: [HsAppType name] -> Maybe (LHsType name, [LHsType name])
getAppsTyHead_maybe :: [LHsAppType name] -> Maybe (LHsType name, [LHsType name])
getAppsTyHead_maybe tys = case splitHsAppsTy tys of
([app1:apps], []) -> -- no symbols, some normal types
Just (mkHsAppTys app1 apps, [])
......@@ -1124,13 +1126,13 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of
-- element of @non_syms@ followed by the first element of @syms@ followed by
-- the next element of @non_syms@, etc. It is guaranteed that the non_syms list
-- has one more element than the syms list.
splitHsAppsTy :: [HsAppType name] -> ([[LHsType name]], [Located name])
splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name])
splitHsAppsTy = go [] [] []
where
go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym)
go acc acc_non acc_sym (HsAppPrefix ty : rest)
go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest)
= go (ty : acc) acc_non acc_sym rest
go acc acc_non acc_sym (HsAppInfix op : rest)
go acc acc_non acc_sym (L _ (HsAppInfix op) : rest)
= go [] (reverse acc : acc_non) (op : acc_sym) rest
-- retrieve the name of the "head" of a nested type application
......
......@@ -1662,12 +1662,12 @@ btype_no_ops :: { LHsType RdrName }
: btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 }
| atype { $1 }
tyapps :: { Located [HsAppType RdrName] } -- NB: This list is reversed
: tyapp { sL1 $1 [unLoc $1] }
| tyapps tyapp { sLL $1 $> $ (unLoc $2) : (unLoc $1) }
tyapps :: { Located [LHsAppType RdrName] } -- NB: This list is reversed
: tyapp { sL1 $1 [$1] }
| tyapps tyapp { sLL $1 $> $ $2 : (unLoc $1) }
-- See Note [HsAppsTy] in HsTypes
tyapp :: { Located (HsAppType RdrName) }
tyapp :: { LHsAppType RdrName }
: atype { sL1 $1 $ HsAppPrefix $1 }
| qtyconop { sL1 $1 $ HsAppInfix $1 }
| tyvarop { sL1 $1 $ HsAppInfix $1 }
......
......@@ -652,10 +652,11 @@ checkTyVars pp_what equals_or_where tc tparms
where
chk (L _ (HsParTy ty)) = chk ty
chk (L _ (HsAppsTy [HsAppPrefix ty])) = chk ty
chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty
-- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsAppsTy [HsAppPrefix (L lv (HsTyVar (L _ tv)))])) k))
chk (L l (HsKindSig
(L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar (L _ tv))))])) k))
| isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k))
chk (L l (HsTyVar (L ltv tv)))
| isRdrTyVar tv = return (L l (UserTyVar (L ltv tv)))
......@@ -715,7 +716,7 @@ checkTyClHdr is_cls ty
go _ (HsAppsTy ts) acc ann
| Just (head, args) <- getAppsTyHead_maybe ts = goL head (args ++ acc) ann
go _ (HsAppsTy [HsAppInfix (L loc star)]) [] ann
go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann
| occNameFS (rdrNameOcc star) == fsLit "*"
= return (L loc (nameRdrName starKindTyConName), [], ann)
| occNameFS (rdrNameOcc star) == fsLit "★"
......@@ -740,7 +741,7 @@ checkContext (L l orig_t)
= return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
-- don't let HsAppsTy get in the way
check anns (L _ (HsAppsTy [HsAppPrefix ty]))
check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)]))
= check anns ty
check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
......@@ -1070,14 +1071,17 @@ splitTilde t = go t
-- | Transform tyapps with strict_marks into uses of twiddle
-- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
splitTildeApps :: [HsAppType RdrName] -> [HsAppType RdrName]
splitTildeApps :: [LHsAppType RdrName] -> [LHsAppType RdrName]
splitTildeApps [] = []
splitTildeApps (t : rest) = t : concatMap go rest
where go (HsAppPrefix
where go (L l (HsAppPrefix
(L loc (HsBangTy
(HsSrcBang Nothing NoSrcUnpack SrcLazy)
ty)))
= [HsAppInfix (L tilde_loc eqTyCon_RDR), HsAppPrefix ty]
ty))))
= [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)),
L l (HsAppPrefix ty)]
-- NOTE: no annotation is attached to an HsAppPrefix, so the
-- surrounding SrcSpan is not critical
where
tilde_loc = srcSpanFirstCharacter loc
......
......@@ -628,7 +628,9 @@ getLocalNonValBinders fixity_env
where
(_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
cdflds = case tau of
L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _) -> flds
L _ (HsFunTy
(L _ (HsAppsTy
[L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
_ -> []
find_con_flds _ = []
......
......@@ -996,7 +996,7 @@ collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)]
collectWildCards lty = go lty
where
go (L loc ty) = case ty of
HsAppsTy tys -> gos (mapMaybe prefix_types_only tys)
HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys)
HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2
HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2
HsListTy ty -> go ty
......@@ -1619,12 +1619,13 @@ extract_lty t_or_k (L _ ty) acc
HsWildCardTy {} -> return acc
extract_apps :: TypeOrKind
-> [HsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
-> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
extract_app :: TypeOrKind -> HsAppType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
extract_app t_or_k (HsAppInfix tv) acc = extract_tv t_or_k tv acc
extract_app t_or_k (HsAppPrefix ty) acc = extract_lty t_or_k ty acc
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_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars
-> FreeKiTyVars -> RnM FreeKiTyVars
......
(12,12,7)
(70,63,0)
(14,13,7)
(93,63,0)
(15,13,7)
(10,10,7)
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