diff options
30 files changed, 360 insertions, 168 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 1d59ae2308..4b543cb8ef 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -626,7 +626,7 @@ getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of InfixCon{} -> Nothing getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of PrefixConGADT{} -> Nothing - RecConGADT flds -> Just flds + RecConGADT flds _ -> Just flds hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] hsConDeclTheta Nothing = [] @@ -708,7 +708,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) where get_args (PrefixConGADT args) = map ppr args - get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)] + get_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields)] ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) ppr_arrow_chain [] = empty diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index 99b0bbc1ab..841604ecb9 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -240,3 +240,8 @@ type instance Anno (HsToken tok) = EpAnnCO noHsTok :: GenLocated (EpAnn a) (HsToken tok) noHsTok = L noAnn HsTok + +type instance Anno (HsUniToken tok utok) = EpAnnCO + +noHsUniTok :: GenLocated (EpAnn a) (HsUniToken tok utok) +noHsUniTok = L noAnn HsNormalTok diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 363b890d59..4ec53aeaf0 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -475,6 +475,11 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) +-- deriving instance Data (HsLinearArrowTokens p) +deriving instance Data (HsLinearArrowTokens GhcPs) +deriving instance Data (HsLinearArrowTokens GhcRn) +deriving instance Data (HsLinearArrowTokens GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsArrow p) deriving instance Data (HsArrow GhcPs) deriving instance Data (HsArrow GhcRn) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 0b5457c35e..3b67c8dd2e 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -24,6 +24,7 @@ module GHC.Hs.Type ( Mult, HsScaled(..), hsMult, hsScaledThing, HsArrow(..), arrowToHsType, + HsLinearArrowTokens(..), hsLinear, hsUnrestricted, isUnrestricted, HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, @@ -285,7 +286,7 @@ type instance XForAllTy (GhcPass _) = NoExtField type instance XQualTy (GhcPass _) = NoExtField type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn] type instance XAppTy (GhcPass _) = NoExtField -type instance XFunTy (GhcPass _) = EpAnn TrailingAnn -- For the AnnRarrow or AnnLolly +type instance XFunTy (GhcPass _) = EpAnnCO type instance XListTy (GhcPass _) = EpAnn AnnParen type instance XTupleTy (GhcPass _) = EpAnn AnnParen type instance XSumTy (GhcPass _) = EpAnn AnnParen @@ -329,6 +330,12 @@ oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName) manyDataConHsTy :: HsType GhcRn manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName) +hsLinear :: a -> HsScaled (GhcPass p) a +hsLinear = HsScaled (HsLinearArrow (HsPct1 noHsTok noHsUniTok)) + +hsUnrestricted :: a -> HsScaled (GhcPass p) a +hsUnrestricted = HsScaled (HsUnrestrictedArrow noHsUniTok) + isUnrestricted :: HsArrow GhcRn -> Bool isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName isUnrestricted _ = False @@ -338,8 +345,8 @@ isUnrestricted _ = False -- multiplicity or a shorthand. arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy -arrowToHsType (HsLinearArrow _ _) = noLocA oneDataConHsTy -arrowToHsType (HsExplicitMult _ _ p) = p +arrowToHsType (HsLinearArrow _) = noLocA oneDataConHsTy +arrowToHsType (HsExplicitMult _ p _) = p instance (OutputableBndrId pass) => @@ -349,8 +356,8 @@ instance -- See #18846 pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc pprHsArrow (HsUnrestrictedArrow _) = arrow -pprHsArrow (HsLinearArrow _ _) = lollipop -pprHsArrow (HsExplicitMult _ _ p) = (mulArrow (ppr p)) +pprHsArrow (HsLinearArrow _) = lollipop +pprHsArrow (HsExplicitMult _ p _) = mulArrow (ppr p) type instance XConDeclField (GhcPass _) = EpAnn [AddEpAnn] type instance XXConDeclField (GhcPass _) = NoExtCon @@ -484,13 +491,12 @@ splitHsFunType ty = go ty cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an in (anns', cs', args, res) - go (L ll (HsFunTy (EpAnn _ an cs) mult x y)) + go (L ll (HsFunTy (EpAnn _ _ cs) mult x y)) | (anns, csy, args, res) <- splitHsFunType y = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res) where - (L (SrcSpanAnn a l) t) = x - an' = addTrailingAnnToA l an cs a - x' = L (SrcSpanAnn an' l) t + L l t = x + x' = L (addCommentsToSrcAnn l cs) t go other = ([], emptyComments, [], other) diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 5c6a53a8a7..42ea9f0ae7 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -609,7 +609,7 @@ nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t)) nlHsTyVar x = noLocA (HsTyVar noAnn NotPromoted (noLocA x)) -nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b) +nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b) nlHsParTy t = noLocA (HsParTy noAnn t) nlHsTyConApp :: IsSrcSpanAnn p a @@ -1473,7 +1473,7 @@ hsConDeclsBinders cons get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p) -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds_gadt remSeen (RecConGADT flds) = get_flds remSeen flds + get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds get_flds_gadt remSeen _ = (remSeen, []) get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)] diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index df2e334213..15771cd26e 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -250,7 +250,7 @@ h98ConArgDocs con_args = case con_args of gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString gadtConArgDocs con_args res_ty = case con_args of PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty] - RecConGADT _ -> con_arg_docs 1 [res_ty] + RecConGADT _ _ -> con_arg_docs 1 [res_ty] con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..] diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index cd7bee26ef..0860192e68 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -2681,7 +2681,7 @@ repGadtDataCons cons details res_ty arg_tys <- repPrefixConArgs ps res_ty' <- repLTy res_ty rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty'] - RecConGADT ips -> do + RecConGADT ips _ -> do arg_vtys <- repRecConArgs ips res_ty' <- repLTy res_ty rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys, diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 4920f1eac8..f198dc55c1 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -1389,7 +1389,7 @@ instance (ToHie tyarg, ToHie arg, ToHie rec) => ToHie (HsConDetails tyarg arg re instance ToHie (HsConDeclGADTDetails GhcRn) where toHie (PrefixConGADT args) = toHie args - toHie (RecConGADT rec) = toHie rec + toHie (RecConGADT rec _) = toHie rec instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where toHie (L span top) = concatM $ makeNode top span : case top of @@ -1622,7 +1622,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where ctxScope = maybe NoScope mkLScopeA ctx argsScope = case args of PrefixConGADT xs -> scaled_args_scope xs - RecConGADT x -> mkLScopeA x + RecConGADT x _ -> mkLScopeA x tyScope = mkLScopeA typ resScope = ResolvedScopes [ctxScope, rhsScope] ConDeclH98 { con_name = name, con_ex_tvs = qvars diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index cc52d67469..15088081e1 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -12,6 +12,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -2147,20 +2148,20 @@ type :: { LHsType GhcPs } -- See Note [%shift: type -> btype] : btype %shift { $1 } | btype '->' ctype {% acsA (\cs -> sLL (reLoc $1) (reLoc $>) - $ HsFunTy (EpAnn (glAR $1) (mau $2) cs) (HsUnrestrictedArrow (toUnicode $2)) $1 $3) } + $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsUnrestrictedArrow (hsUniTok $2)) $1 $3) } | btype mult '->' ctype {% hintLinear (getLoc $2) - >> let arr = (unLoc $2) (toUnicode $3) + >> let arr = (unLoc $2) (hsUniTok $3) in acsA (\cs -> sLL (reLoc $1) (reLoc $>) - $ HsFunTy (EpAnn (glAR $1) (mau $3) cs) arr $1 $4) } + $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) arr $1 $4) } | btype '->.' ctype {% hintLinear (getLoc $2) >> acsA (\cs -> sLL (reLoc $1) (reLoc $>) - $ HsFunTy (EpAnn (glAR $1) (mlu $2) cs) (HsLinearArrow UnicodeSyntax Nothing) $1 $3) } + $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsLinearArrow (HsLolly (hsTok $2))) $1 $3) } -- [mu AnnLollyU $2] } -mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) } - : PREFIX_PERCENT atype { sLL $1 (reLoc $>) (\u -> mkMultTy u $1 $2) } +mult :: { Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs) } + : PREFIX_PERCENT atype { sLL $1 (reLoc $>) (mkMultTy (hsTok $1) $2) } btype :: { LHsType GhcPs } : infixtype {% runPV $1 } @@ -4178,13 +4179,6 @@ msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l mu :: AnnKeywordId -> Located Token -> AddEpAnn mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l) -mau :: Located Token -> TrailingAnn -mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (EpaSpan $ rs l) - else AddRarrowAnn (EpaSpan $ rs l) - -mlu :: Located Token -> TrailingAnn -mlu lt@(L l t) = AddLollyAnnU (EpaSpan $ rs l) - -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId @@ -4350,7 +4344,12 @@ listAsAnchor [] = spanAsAnchor noSrcSpan listAsAnchor (L l _:_) = spanAsAnchor (locA l) hsTok :: Located Token -> LHsToken tok GhcPs -hsTok (L l _) = L (EpAnn (Anchor (realSrcSpan l) UnchangedAnchor) NoEpAnns emptyComments) HsTok +hsTok (L l _) = L (EpAnn (spanAsAnchor l) NoEpAnns emptyComments) HsTok + +hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs +hsUniTok t@(L l _) = + L (EpAnn (spanAsAnchor l) NoEpAnns emptyComments) + (if isUnicode t then HsUnicodeTok else HsNormalTok) -- ------------------------------------- diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index abece56898..19925b0678 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -621,18 +621,12 @@ data TrailingAnn = AddSemiAnn EpaLocation -- ^ Trailing ';' | AddCommaAnn EpaLocation -- ^ Trailing ',' | AddVbarAnn EpaLocation -- ^ Trailing '|' - | AddRarrowAnn EpaLocation -- ^ Trailing '->' - | AddRarrowAnnU EpaLocation -- ^ Trailing '->', unicode variant - | AddLollyAnnU EpaLocation -- ^ Trailing '⊸' deriving (Data,Show,Eq, Ord) instance Outputable TrailingAnn where ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss ppr (AddCommaAnn ss) = text "AddCommaAnn" <+> ppr ss ppr (AddVbarAnn ss) = text "AddVbarAnn" <+> ppr ss - ppr (AddRarrowAnn ss) = text "AddRarrowAnn" <+> ppr ss - ppr (AddRarrowAnnU ss) = text "AddRarrowAnnU" <+> ppr ss - ppr (AddLollyAnnU ss) = text "AddLollyAnnU" <+> ppr ss -- | Annotation for items appearing in a list. They can have one or -- more trailing punctuations items, such as commas or semicolons. @@ -1016,7 +1010,6 @@ setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts -- Comment-only annotations -- --------------------------------------------------------------------- --- TODO:AZ I think EpAnnCO is not needed type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only data NoEpAnns = NoEpAnns @@ -1127,6 +1120,9 @@ instance Semigroup EpAnnComments where instance (Monoid a) => Monoid (EpAnn a) where mempty = EpAnnNotUsed +instance Semigroup NoEpAnns where + _ <> _ = NoEpAnns + instance Semigroup AnnListItem where (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index ffe44227fd..946b9a87f3 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -719,13 +719,14 @@ mkGadtDecl loc names ty annsIn = do (args, res_ty, annsa, csa) <- case body_ty of L ll (HsFunTy af hsArr (L loc' (HsRecTy an rf)) res_ty) -> do - let an' = addTrailingAnnToL (locA loc') (anns af) (comments af) an - case hsArr of - HsUnrestrictedArrow _ -> return () - _ -> addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $ + let an' = addCommentsToEpAnn (locA loc') an (comments af) + arr <- case hsArr of + HsUnrestrictedArrow arr -> return arr + _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $ (PsErrIllegalGadtRecordMultiplicity hsArr) + return noHsUniTok - return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf), res_ty + return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr, res_ty , [], epAnnComments (ann ll)) _ -> do let (anns, cs, arg_types, res_type) = splitHsFunType body_ty @@ -2980,11 +2981,15 @@ mkLHsOpTy x op y = let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y in L loc (mkHsOpTy x op y) -mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> HsArrow GhcPs -mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) +mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs +mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr -- See #18888 for the use of (SourceText "1") above - = HsLinearArrow u (Just $ AddEpAnn AnnPercentOne (EpaSpan $ realSrcSpan $ combineLocs tok (reLoc t))) -mkMultTy u tok t = HsExplicitMult u (Just $ AddEpAnn AnnPercent (EpaSpan $ realSrcSpan $ getLoc tok)) t + = HsLinearArrow (HsPct1 (L (getLoc pct Semi.<> locOf1) HsTok) arr) + where + -- The location of "1" in "%1". + locOf1 :: EpAnn NoEpAnns + locOf1 = EpAnn (spanAsAnchor (locA (getLoc t))) NoEpAnns emptyComments +mkMultTy pct t arr = HsExplicitMult pct t arr ----------------------------------------------------------------------------- -- Token symbols diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 88988b2ea6..5cb81edcdb 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -695,10 +695,10 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where con_g_args' <- case con_g_args of PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts - RecConGADT (L l_rec flds) -> do + RecConGADT (L l_rec flds) arr -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds - pure $ RecConGADT (L l_rec flds') + pure $ RecConGADT (L l_rec flds') arr con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 92228b0003..ea4ac365b1 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -764,10 +764,11 @@ rnHsTyKi env (HsWildCardTy _) ; return (HsWildCardTy noExtField, emptyFVs) } rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars) -rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs) -rnHsArrow _env (HsLinearArrow u a) = return (HsLinearArrow u a, emptyFVs) -rnHsArrow env (HsExplicitMult u a p) - = (\(mult, fvs) -> (HsExplicitMult u a mult, fvs)) <$> rnLHsTyKi env p +rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs) +rnHsArrow _env (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr), emptyFVs) +rnHsArrow _env (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr), emptyFVs) +rnHsArrow env (HsExplicitMult pct p arr) + = (\(mult, fvs) -> (HsExplicitMult pct mult arr, fvs)) <$> rnLHsTyKi env p {- Note [Renaming HsCoreTys] @@ -1891,8 +1892,8 @@ extractRdrKindSigVars (L _ resultSig) = case resultSig of extractConDeclGADTDetailsTyVars :: HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars extractConDeclGADTDetailsTyVars con_args = case con_args of - PrefixConGADT args -> extract_scaled_ltys args - RecConGADT (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds + PrefixConGADT args -> extract_scaled_ltys args + RecConGADT (L _ flds) _ -> extract_ltys $ map (cd_fld_type . unLoc) $ flds -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order: @@ -1966,7 +1967,7 @@ extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars -extract_hs_arrow (HsExplicitMult _ _ p) acc = extract_lty p acc +extract_hs_arrow (HsExplicitMult _ p _) acc = extract_lty p acc extract_hs_arrow _ acc = acc extract_hs_for_all_telescope :: HsForAllTelescope GhcPs diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 61aa6a54d2..55cc83456e 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -2389,9 +2389,9 @@ rnConDeclGADTDetails :: rnConDeclGADTDetails _ doc (PrefixConGADT tys) = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys ; return (PrefixConGADT new_tys, fvs) } -rnConDeclGADTDetails con doc (RecConGADT flds) +rnConDeclGADTDetails con doc (RecConGADT flds arr) = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds - ; return (RecConGADT new_flds, fvs) } + ; return (RecConGADT new_flds arr, fvs) } rnRecConDeclFields :: Name diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 6d4806fe47..05bbb71c6e 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -888,7 +888,7 @@ getLocalNonValBinders fixity_env = [( find_con_name rdr , concatMap find_con_decl_flds (unLoc cdflds) )] find_con_flds (L _ (ConDeclGADT { con_names = rdrs - , con_g_args = RecConGADT flds })) + , con_g_args = RecConGADT flds _ })) = [ ( find_con_name rdr , concatMap find_con_decl_flds (unLoc flds)) | L _ rdr <- rdrs ] diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 83cfad2a1e..8de1974627 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1163,7 +1163,7 @@ tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind | op `hasKey` funTyConKey - = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind + = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind --------- Foralls tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 1af410fd7b..a025190003 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -1630,9 +1630,9 @@ kcConH98Args new_or_data res_kind con_args = case con_args of -- Kind-check the types of arguments to a GADT data constructor. kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM () kcConGADTArgs new_or_data res_kind con_args = case con_args of - PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys - RecConGADT (L _ flds) -> kcConArgTys new_or_data res_kind $ - map (hsLinear . cd_fld_type . unLoc) flds + PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys + RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $ + map (hsLinear . cd_fld_type . unLoc) flds kcConDecls :: NewOrData -> Kind -- The result kind signature @@ -3676,7 +3676,7 @@ tcConGADTArgs :: ContextKind -- expected kind of arguments -> TcM [(Scaled TcType, HsSrcBang)] tcConGADTArgs exp_kind (PrefixConGADT btys) = mapM (tcConArg exp_kind) btys -tcConGADTArgs exp_kind (RecConGADT fields) +tcConGADTArgs exp_kind (RecConGADT fields _) = tcRecConDeclFields exp_kind fields tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 7aa9b73eb2..edd5301907 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -659,7 +659,7 @@ cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameN c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; returnLA $ mk_gadt_decl c' (RecConGADT $ noLocA rec_flds) ty' } + ; returnLA $ mk_gadt_decl c' (RecConGADT (noLocA rec_flds) noHsUniTok) ty' } mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs @@ -1518,7 +1518,7 @@ cvtTypeKind ty_str ty _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' - returnLA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x'' y'') + returnLA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x'' y'') | otherwise -> mk_apps (HsTyVar noAnn NotPromoted (noLocA (getRdrName unrestrictedFunTyCon))) @@ -1675,9 +1675,9 @@ cvtTypeKind ty_str ty hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs hsTypeToArrow w = case unLoc w of HsTyVar _ _ (L _ (isExact_maybe -> Just n)) - | n == oneDataConName -> HsLinearArrow NormalSyntax Nothing - | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax - _ -> HsExplicitMult NormalSyntax Nothing w + | n == oneDataConName -> HsLinearArrow (HsPct1 noHsTok noHsUniTok) + | n == manyDataConName -> HsUnrestrictedArrow noHsUniTok + _ -> HsExplicitMult noHsTok w noHsUniTok -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index fcbb5856b1..df06635ab3 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -1215,7 +1216,7 @@ type HsConDeclH98Details pass -- GHC.Tc.TyCl—but that is an orthogonal concern.) data HsConDeclGADTDetails pass = PrefixConGADT [HsScaled pass (LBangType pass)] - | RecConGADT (XRec pass [LConDeclField pass]) + | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass) instance Outputable NewOrData where ppr NewType = text "newtype" diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index 278b8aa99e..8d8eadf135 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -706,3 +706,16 @@ type LHsToken tok p = XRec p (HsToken tok) data HsToken (tok :: Symbol) = HsTok deriving instance KnownSymbol tok => Data (HsToken tok) + +type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) + +-- With UnicodeSyntax, there might be multiple ways to write the same token. +-- For example an arrow could be either "->" or "→". This choice must be +-- recorded in order to exactprint such tokens, +-- so instead of HsToken "->" we introduce HsUniToken "->" "→". +-- +-- See also IsUnicodeSyntax in GHC.Parser.Annotation; we do not use here to +-- avoid a dependency. +data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok + +deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 1b311716d0..74f8f98432 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -7,6 +7,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {- @@ -22,7 +23,7 @@ module Language.Haskell.Syntax.Type ( Mult, HsScaled(..), hsMult, hsScaledThing, HsArrow(..), - hsLinear, hsUnrestricted, + HsLinearArrowTokens(..), HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, @@ -913,16 +914,20 @@ data HsTyLit -- | Denotes the type of arrows in the surface language data HsArrow pass - = HsUnrestrictedArrow IsUnicodeSyntax + = HsUnrestrictedArrow !(LHsUniToken "->" "→" pass) -- ^ a -> b or a → b - | HsLinearArrow IsUnicodeSyntax (Maybe AddEpAnn) + | HsLinearArrow !(HsLinearArrowTokens pass) -- ^ a %1 -> b or a %1 → b, or a ⊸ b - | HsExplicitMult IsUnicodeSyntax (Maybe AddEpAnn) (LHsType pass) + | HsExplicitMult !(LHsToken "%" pass) !(LHsType pass) !(LHsUniToken "->" "→" pass) -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`! -- This is how the programmer wrote it). It is stored as an -- `HsType` so as to preserve the syntax as written in the -- program. +data HsLinearArrowTokens pass + = HsPct1 !(LHsToken "%1" pass) !(LHsUniToken "->" "→" pass) + | HsLolly !(LHsToken "⊸" pass) + -- | This is used in the syntax. In constructor declaration. It must keep the -- arrow representation. data HsScaled pass a = HsScaled (HsArrow pass) a @@ -933,12 +938,6 @@ hsMult (HsScaled m _) = m hsScaledThing :: HsScaled pass a -> a hsScaledThing (HsScaled _ t) = t --- | When creating syntax we use the shorthands. It's better for printing, also, --- the shorthands work trivially at each pass. -hsUnrestricted, hsLinear :: a -> HsScaled pass a -hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax) -hsLinear = HsScaled (HsLinearArrow NormalSyntax Nothing) - instance Outputable a => Outputable (HsScaled pass a) where ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t ppr t diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index 622ba39adf..8054c405c8 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -112,12 +112,19 @@ (Anchor { T17544.hs:6:9 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { T17544.hs:6:11-12 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { T17544.hs:6:11-12 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:6:9 }) (HsTyVar @@ -239,12 +246,19 @@ (Anchor { T17544.hs:10:9 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { T17544.hs:10:11-12 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { T17544.hs:10:11-12 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:10:9 }) (HsTyVar @@ -362,12 +376,19 @@ (Anchor { T17544.hs:14:9 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { T17544.hs:14:11-12 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { T17544.hs:14:11-12 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:14:9 }) (HsTyVar @@ -488,12 +509,19 @@ (Anchor { T17544.hs:18:9 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { T17544.hs:18:11-12 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { T17544.hs:18:11-12 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:18:9 }) (HsTyVar @@ -554,12 +582,19 @@ (Anchor { T17544.hs:20:9 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { T17544.hs:20:11-12 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { T17544.hs:20:11-12 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:20:9 }) (HsTyVar diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr index 82d2122d3e..6831df7140 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -166,15 +166,22 @@ (PrefixConGADT [(HsScaled (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { T17544_kw.hs:19:21-22 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnn (Anchor { T17544_kw.hs:19:18-19 } (UnchangedAnchor)) (AnnListItem - [(AddRarrowAnn - (EpaSpan { T17544_kw.hs:19:21-22 }))]) + []) (EpaComments [])) { T17544_kw.hs:19:18-19 }) (HsTupleTy @@ -312,3 +319,5 @@ { T17544_kw.hs:12:3-33 } (HsDocString " Bad comment for the module"))))) + + diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 025df2068b..de37b069d1 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -144,8 +144,13 @@ [] [(HsScaled (HsLinearArrow - (NormalSyntax) - (Nothing)) + (HsPct1 + (L + (EpAnnNotUsed) + (HsTok)) + (L + (EpAnnNotUsed) + (HsNormalTok)))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:8:26-30 }) (HsTyVar @@ -549,8 +554,13 @@ [] [(HsScaled (HsLinearArrow - (NormalSyntax) - (Nothing)) + (HsPct1 + (L + (EpAnnNotUsed) + (HsTok)) + (L + (EpAnnNotUsed) + (HsNormalTok)))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:15:25-29 }) (HsParTy @@ -831,12 +841,19 @@ (Anchor { DumpParsedAst.hs:17:31 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { DumpParsedAst.hs:17:33-34 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpParsedAst.hs:17:33-34 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:17:31 }) (HsTyVar @@ -978,4 +995,6 @@ (FromSource)) [])))] (Nothing) - (Nothing)))
\ No newline at end of file + (Nothing))) + + diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index a205c8af53..b595315435 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -148,8 +148,13 @@ [] [(HsScaled (HsLinearArrow - (NormalSyntax) - (Nothing)) + (HsPct1 + (L + (EpAnnNotUsed) + (HsTok)) + (L + (EpAnnNotUsed) + (HsNormalTok)))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:10:26-30 }) (HsTyVar @@ -375,12 +380,19 @@ (Anchor { DumpRenamedAst.hs:16:20 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { DumpRenamedAst.hs:16:22-23 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpRenamedAst.hs:16:22-23 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:16:20 }) (HsTyVar @@ -396,12 +408,19 @@ (Anchor { DumpRenamedAst.hs:16:25 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { DumpRenamedAst.hs:16:27-28 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpRenamedAst.hs:16:27-28 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:16:25 }) (HsTyVar @@ -471,12 +490,19 @@ (Anchor { DumpRenamedAst.hs:19:28 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { DumpRenamedAst.hs:19:30-31 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpRenamedAst.hs:19:30-31 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:19:28 }) (HsTyVar @@ -507,12 +533,19 @@ (Anchor { DumpRenamedAst.hs:19:42-52 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { DumpRenamedAst.hs:19:54-55 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpRenamedAst.hs:19:54-55 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:19:42-52 }) (HsParTy @@ -524,12 +557,19 @@ (Anchor { DumpRenamedAst.hs:19:43 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { DumpRenamedAst.hs:19:45-46 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpRenamedAst.hs:19:45-46 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:19:43 }) (HsTyVar @@ -570,15 +610,22 @@ (PrefixConGADT [(HsScaled (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpRenamedAst.hs:20:36-37 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnn (Anchor { DumpRenamedAst.hs:20:10-34 } (UnchangedAnchor)) (AnnListItem - [(AddRarrowAnn - (EpaSpan { DumpRenamedAst.hs:20:36-37 }))]) + []) (EpaComments [])) { DumpRenamedAst.hs:20:10-34 }) (HsParTy @@ -610,12 +657,19 @@ (Anchor { DumpRenamedAst.hs:20:22-25 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { DumpRenamedAst.hs:20:27-28 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpRenamedAst.hs:20:27-28 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:20:22-25 }) (HsAppTy @@ -771,8 +825,13 @@ [] [(HsScaled (HsLinearArrow - (NormalSyntax) - (Nothing)) + (HsPct1 + (L + (EpAnnNotUsed) + (HsTok)) + (L + (EpAnnNotUsed) + (HsNormalTok)))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:22:25-29 }) (HsParTy @@ -955,12 +1014,19 @@ (Anchor { DumpRenamedAst.hs:24:31 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { DumpRenamedAst.hs:24:33-34 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { DumpRenamedAst.hs:24:33-34 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:24:31 }) (HsTyVar @@ -1302,3 +1368,5 @@ {Name: GHC.Types.Type})))))])))))] (Nothing) (Nothing))) + + diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 570a9d6650..ad5009011b 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -679,12 +679,19 @@ (Anchor { KindSigs.hs:22:8-20 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { KindSigs.hs:22:22-23 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { KindSigs.hs:22:22-23 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { KindSigs.hs:22:8-20 }) (HsParTy @@ -745,12 +752,19 @@ (Anchor { KindSigs.hs:22:25-28 } (UnchangedAnchor)) - (AddRarrowAnn - (EpaSpan { KindSigs.hs:22:30-31 })) + (NoEpAnns) (EpaComments [])) (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { KindSigs.hs:22:30-31 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnnNotUsed) { KindSigs.hs:22:25-28 }) (HsTyVar @@ -1505,3 +1519,5 @@ [])))] (Nothing) (Nothing))) + + diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index f5cd2ecb36..ecfcae56c8 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -61,8 +61,13 @@ [] [(HsScaled (HsLinearArrow - (NormalSyntax) - (Nothing)) + (HsPct1 + (L + (EpAnnNotUsed) + (HsTok)) + (L + (EpAnnNotUsed) + (HsNormalTok)))) (L (SrcSpanAnn (EpAnnNotUsed) { T14189.hs:6:18-20 }) (HsTyVar @@ -211,3 +216,4 @@ {Name: T14189.f}))])])]) (Nothing))) + diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr index ac100b217e..abde8320b1 100644 --- a/testsuite/tests/printer/T18791.stderr +++ b/testsuite/tests/printer/T18791.stderr @@ -90,15 +90,22 @@ (PrefixConGADT [(HsScaled (HsUnrestrictedArrow - (NormalSyntax)) + (L + (EpAnn + (Anchor + { T18791.hs:5:14-15 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsNormalTok))) (L (SrcSpanAnn (EpAnn (Anchor { T18791.hs:5:10-12 } (UnchangedAnchor)) (AnnListItem - [(AddRarrowAnn - (EpaSpan { T18791.hs:5:14-15 }))]) + []) (EpaComments [])) { T18791.hs:5:10-12 }) (HsTyVar @@ -133,3 +140,5 @@ []))))] (Nothing) (Nothing))) + + diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 274b6aa464..fc45e8f9e4 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -492,20 +492,18 @@ markLocatedAALS (EpAnn _ a _) f kw (Just str) = go (f a) -- --------------------------------------------------------------------- -markArrow :: EpAnn TrailingAnn -> HsArrow GhcPs -> EPP () -markArrow an arr = do - case arr of - HsUnrestrictedArrow _u -> - return () - HsLinearArrow _u ma -> do - mapM_ markAddEpAnn ma - HsExplicitMult _u ma t -> do - mapM_ markAddEpAnn ma - markAnnotated t - - case an of - EpAnnNotUsed -> pure () - _ -> markKwT (anns an) +markArrow :: HsArrow GhcPs -> EPP () +markArrow (HsUnrestrictedArrow arr) = do + markUniToken arr +markArrow (HsLinearArrow (HsPct1 pct1 arr)) = do + markToken pct1 + markUniToken arr +markArrow (HsLinearArrow (HsLolly arr)) = do + markToken arr +markArrow (HsExplicitMult pct t arr) = do + markToken pct + markAnnotated t + markUniToken arr -- --------------------------------------------------------------------- @@ -584,10 +582,6 @@ markKwT :: TrailingAnn -> EPP () markKwT (AddSemiAnn ss) = markKwA AnnSemi ss markKwT (AddCommaAnn ss) = markKwA AnnComma ss markKwT (AddVbarAnn ss) = markKwA AnnVbar ss -markKwT (AddRarrowAnn ss) = markKwA AnnRarrow ss -markKwT (AddRarrowAnnU ss) = markKwA AnnRarrowU ss --- markKwT (AddLollyAnn ss) = markKwA AnnLolly ss -markKwT (AddLollyAnnU ss) = markKwA AnnLollyU ss markKw :: AddEpAnn -> EPP () markKw (AddEpAnn kw ss) = markKwA kw ss @@ -603,6 +597,10 @@ markToken (L (EpAnn (Anchor a a_op) _ _) _) = printStringAtAA aa (symbolVal (Pro UnchangedAnchor -> EpaSpan a MovedAnchor dp -> EpaDelta dp +markUniToken :: forall tok utok. (KnownSymbol tok, KnownSymbol utok) => LHsUniToken tok utok GhcPs -> EPP () +markUniToken (L l HsNormalTok) = markToken (L l (HsTok @tok)) +markUniToken (L l HsUnicodeTok) = markToken (L l (HsTok @utok)) + -- --------------------------------------------------------------------- markAnnList :: Bool -> EpAnn AnnList -> EPP () -> EPP () @@ -3015,9 +3013,9 @@ instance ExactPrint (HsType GhcPs) where markAnnotated ty printStringAtSs ss "@" markAnnotated ki - exact (HsFunTy an mult ty1 ty2) = do + exact (HsFunTy _an mult ty1 ty2) = do markAnnotated ty1 - markArrow an mult + markArrow mult markAnnotated ty2 exact (HsListTy an tys) = do markOpeningParen an @@ -3328,8 +3326,10 @@ instance ExactPrint (ConDecl GhcPs) where when (isJust mcxt) $ markEpAnn an AnnDarrow -- mapM_ markAnnotated args case args of - (PrefixConGADT args') -> mapM_ markAnnotated args' - (RecConGADT fields) -> markAnnotated fields + PrefixConGADT args' -> mapM_ markAnnotated args' + RecConGADT fields arr -> do + markAnnotated fields + markUniToken arr -- mapM_ markAnnotated (unLoc fields) markAnnotated res_ty -- markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) qvars mbCxt args typ _) = do @@ -3427,7 +3427,7 @@ instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where getAnnotationEntry = const NoEntryVal exact (HsScaled arr t) = do markAnnotated t - markArrow EpAnnNotUsed arr + markArrow arr -- --------------------------------------------------------------------- diff --git a/utils/haddock b/utils/haddock -Subproject 126beaef07cdcbe8aeea248cc555e8a3057de82 +Subproject 0029f289bec7427032785f13cf3bcdebddf7b91 |