[Git][ghc/ghc][wip/az/unicode-hsscaled] API Annotations: Keep track of unicode for linear arrow notation
Alan Zimmerman
gitlab at gitlab.haskell.org
Fri Oct 9 14:16:59 UTC 2020
Alan Zimmerman pushed to branch wip/az/unicode-hsscaled at Glasgow Haskell Compiler / GHC
Commits:
a6c8953a by Alan Zimmerman at 2020-10-09T15:16:42+01:00
API Annotations: Keep track of unicode for linear arrow notation
The linear arrow can be parsed as `%1 ->` or a direct single token unicode
equivalent.
Make sure that this distinction is captured in the parsed AST by using
IsUnicodeSyntax where it appears, and introduce a new API Annotation,
AnnMult to represent its location when unicode is not used.
Updated haddock submodule
- - - - -
18 changed files:
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/ThToHs.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/parser/should_compile/DumpParsedAst.stderr
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/KindSigs.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- testsuite/tests/printer/T18791.stderr
- utils/haddock
Changes:
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -879,7 +879,7 @@ type instance XForAllTy (GhcPass _) = NoExtField
type instance XQualTy (GhcPass _) = NoExtField
type instance XTyVar (GhcPass _) = NoExtField
type instance XAppTy (GhcPass _) = NoExtField
-type instance XFunTy (GhcPass _) = NoExtField
+type instance XFunTy (GhcPass _) = IsUnicodeSyntax
type instance XListTy (GhcPass _) = NoExtField
type instance XTupleTy (GhcPass _) = NoExtField
type instance XSumTy (GhcPass _) = NoExtField
@@ -953,23 +953,23 @@ arrowToHsType (HsExplicitMult p) = p
-- | This is used in the syntax. In constructor declaration. It must keep the
-- arrow representation.
-data HsScaled pass a = HsScaled (HsArrow pass) a
+data HsScaled pass a = HsScaled IsUnicodeSyntax (HsArrow pass) a
hsMult :: HsScaled pass a -> HsArrow pass
-hsMult (HsScaled m _) = m
+hsMult (HsScaled _ m _) = m
hsScaledThing :: HsScaled pass a -> a
-hsScaledThing (HsScaled _ t) = t
+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
-hsLinear = HsScaled HsLinearArrow
+hsUnrestricted = HsScaled NormalSyntax HsUnrestrictedArrow
+hsLinear = HsScaled NormalSyntax HsLinearArrow
instance Outputable a => Outputable (HsScaled pass a) where
- ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t
- ppr t
+ ppr (HsScaled _ _cnt t) = -- ppr cnt <> ppr t
+ ppr t
instance
(OutputableBndrId pass) =>
@@ -1335,9 +1335,9 @@ splitHsFunType ty = go ty []
go (L l (HsParTy _ ty)) anns
= go ty (anns ++ mkParensApiAnn l)
- go (L _ (HsFunTy _ mult x y)) anns
+ go (L _ (HsFunTy u mult x y)) anns
| (args, res, anns') <- go y anns
- = (HsScaled mult x:args, res, anns')
+ = (HsScaled u mult x:args, res, anns')
go other anns = ([], other, anns)
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -133,6 +133,7 @@ import GHC.Types.SrcLoc
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Settings.Constants
+import GHC.Parser.Annotation
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -542,7 +543,7 @@ nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t))
nlHsTyVar x = noLoc (HsTyVar noExtField NotPromoted (noLoc x))
-nlHsFunTy mult a b = noLoc (HsFunTy noExtField mult (parenthesizeHsType funPrec a) b)
+nlHsFunTy mult a b = noLoc (HsFunTy NormalSyntax mult (parenthesizeHsType funPrec a) b)
nlHsParTy t = noLoc (HsParTy noExtField t)
nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1526,7 +1526,7 @@ instance ToHie (Located OverlapMode) where
toHie (L span _) = locOnly span
instance ToHie a => ToHie (HsScaled GhcRn a) where
- toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]
+ toHie (HsScaled _ w t) = concatM [toHie (arrowToHsType w), toHie t]
instance ToHie (Located (ConDecl GhcRn)) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2051,18 +2051,18 @@ is connected to the first type too.
type :: { LHsType GhcPs }
-- See Note [%shift: type -> btype]
: btype %shift { $1 }
- | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy noExtField HsUnrestrictedArrow $1 $3)
+ | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See Note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $ HsFunTy NormalSyntax HsUnrestrictedArrow $1 $3)
[mu AnnRarrow $2] }
| btype mult '->' ctype {% hintLinear (getLoc $2)
- >> ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy noExtField (unLoc $2) $1 $4)
- [mu AnnRarrow $3] }
+ >> ams $1 [mj AnnMult $2,mu AnnRarrow $3] -- See Note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $ HsFunTy NormalSyntax (unLoc $2) $1 $4)
+ [mj AnnMult $2,mu AnnRarrow $3] }
| btype '->.' ctype {% hintLinear (getLoc $2)
>> ams $1 [mu AnnLollyU $2] -- See note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy noExtField HsLinearArrow $1 $3)
+ >> ams (sLL $1 $> $ HsFunTy UnicodeSyntax HsLinearArrow $1 $3)
[mu AnnLollyU $2] }
mult :: { Located (HsArrow GhcPs) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -301,6 +301,7 @@ data AnnKeywordId
| AnnMdo
| AnnMinus -- ^ '-'
| AnnModule
+ | AnnMult -- ^ '%1'
| AnnNewtype
| AnnName -- ^ where a name loses its location in the AST, this carries it
| AnnOf
=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -784,10 +784,10 @@ getConDoc l =
addHaddockConDeclFieldTy
:: HsScaled GhcPs (LHsType GhcPs)
-> ConHdkA (HsScaled GhcPs (LHsType GhcPs))
-addHaddockConDeclFieldTy (HsScaled mult (L l t)) =
+addHaddockConDeclFieldTy (HsScaled u mult (L l t)) =
WriterT $ extendHdkA l $ liftHdkA $ do
mDoc <- getPrevNextDoc l
- return (HsScaled mult (mkLHsDocTy (L l t) mDoc),
+ return (HsScaled u mult (mkLHsDocTy (L l t) mDoc),
HasInnerDocs (isJust mDoc))
-- Add documentation comment to a data constructor field.
@@ -837,7 +837,7 @@ addConTrailingDoc l_sep =
if has_inner_docs then do
let mk_doc_ty :: HsScaled GhcPs (LHsType GhcPs)
-> HdkM (HsScaled GhcPs (LHsType GhcPs))
- mk_doc_ty x@(HsScaled _ (L _ HsDocTy{})) =
+ mk_doc_ty x@(HsScaled _ _ (L _ HsDocTy{})) =
-- Happens in the following case:
--
-- data T =
@@ -848,9 +848,9 @@ addConTrailingDoc l_sep =
--
-- See tests/.../haddockExtraDocs.hs
x <$ reportExtraDocs trailingDocs
- mk_doc_ty (HsScaled mult (L l' t)) = do
+ mk_doc_ty (HsScaled u mult (L l' t)) = do
doc <- selectDocString trailingDocs
- return $ HsScaled mult (mkLHsDocTy (L l' t) doc)
+ return $ HsScaled u mult (mkLHsDocTy (L l' t) doc)
let mk_doc_fld :: LConDeclField GhcPs
-> HdkM (LConDeclField GhcPs)
mk_doc_fld x@(L _ (ConDeclField { cd_fld_doc = Just _ })) =
@@ -928,7 +928,7 @@ We implement this in two steps:
-}
instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where
- addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a
+ addHaddock (HsScaled u mult a) = HsScaled u mult <$> addHaddock a
instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t
@@ -981,10 +981,10 @@ instance HasHaddock (Located (HsType GhcPs)) where
pure $ L l (HsQualTy noExtField lhs rhs')
-- arg -> res
- HsFunTy _ mult lhs rhs -> do
+ HsFunTy u mult lhs rhs -> do
lhs' <- addHaddock lhs
rhs' <- addHaddock rhs
- pure $ L l (HsFunTy noExtField mult lhs' rhs')
+ pure $ L l (HsFunTy u mult lhs' rhs')
-- other types
_ -> liftHdkA $ do
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -512,10 +512,10 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
-rnScaledLHsType doc (HsScaled w ty) = do
+rnScaledLHsType doc (HsScaled u w ty) = do
(w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w
(ty', fvs) <- rnLHsType doc ty
- return (HsScaled w' ty', fvs `plusFV` fvs_w)
+ return (HsScaled u w' ty', fvs `plusFV` fvs_w)
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
@@ -622,11 +622,11 @@ rnHsTyKi env ty@(HsRecTy _ flds)
2 (ppr ty))
; return [] }
-rnHsTyKi env (HsFunTy _ mult ty1 ty2)
+rnHsTyKi env (HsFunTy u mult ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
; (mult', w_fvs) <- rnHsArrow env mult
- ; return (HsFunTy noExtField mult' ty1' ty2'
+ ; return (HsFunTy u mult' ty1' ty2'
, plusFVs [fvs1, fvs2, w_fvs]) }
rnHsTyKi env listTy@(HsListTy _ ty)
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -116,6 +116,7 @@ import GHC.Data.FastString
import GHC.Builtin.Names hiding ( wildCardName )
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Parser.Annotation
import GHC.Data.Maybe
import GHC.Data.Bag( unitBag )
@@ -1245,13 +1246,13 @@ tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of
; ty1' <- tc_lhs_type mode ty1 arg_k
; ty2' <- tc_lhs_type mode ty2 res_k
; mult' <- tc_mult mode mult
- ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')
+ ; checkExpectedKind (HsFunTy NormalSyntax mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')
liftedTypeKind exp_kind }
KindLevel -> -- no representation polymorphism in kinds. yet.
do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind
; ty2' <- tc_lhs_type mode ty2 liftedTypeKind
; mult' <- tc_mult mode mult
- ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')
+ ; checkExpectedKind (HsFunTy NormalSyntax mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')
liftedTypeKind exp_kind }
{- Note [Skolem escape and forall-types]
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1570,8 +1570,8 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM ()
kcConArgTys new_or_data res_kind arg_tys = do
{ let exp_kind = getArgExpKind new_or_data res_kind
- ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind
- tcMult mult)
+ ; forM_ arg_tys (\(HsScaled _ mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind
+ tcMult mult)
-- See Note [Implementation of UnliftedNewtypes], STEP 2
}
@@ -3408,7 +3408,7 @@ tcConArgs exp_kind (RecCon fields)
tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes,
-- but might be an unlifted type with UnliftedNewtypes
-> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)
-tcConArg exp_kind (HsScaled w bty)
+tcConArg exp_kind (HsScaled _ w bty)
= do { traceTc "tcConArg 1" (ppr bty)
; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind
; w' <- tcDataConMult w
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -51,6 +51,7 @@ import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
+import GHC.Parser.Annotation
import qualified Data.ByteString as BS
import Control.Monad( unless, ap )
@@ -1471,7 +1472,7 @@ cvtTypeKind ty_str ty
_ -> return $
parenthesizeHsType sigPrec x'
let y'' = parenthesizeHsType sigPrec y'
- returnL (HsFunTy noExtField HsUnrestrictedArrow x'' y'')
+ returnL (HsFunTy NormalSyntax HsUnrestrictedArrow x'' y'')
| otherwise
-> mk_apps
(HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon)))
@@ -1487,7 +1488,7 @@ cvtTypeKind ty_str ty
parenthesizeHsType sigPrec x'
let y'' = parenthesizeHsType sigPrec y'
w'' = hsTypeToArrow w'
- returnL (HsFunTy noExtField w'' x'' y'')
+ returnL (HsFunTy NormalSyntax w'' x'' y'')
| otherwise
-> mk_apps
(HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon)))
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr
=====================================
@@ -43,7 +43,7 @@
(NoExtField)
({ T17544.hs:6:9-16 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ T17544.hs:6:9 }
(HsTyVar
@@ -103,7 +103,7 @@
(NoExtField)
({ T17544.hs:10:9-16 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ T17544.hs:10:9 }
(HsTyVar
@@ -160,7 +160,7 @@
(NoExtField)
({ T17544.hs:14:9-16 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ T17544.hs:14:9 }
(HsTyVar
@@ -220,7 +220,7 @@
(NoExtField)
({ T17544.hs:18:9-16 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ T17544.hs:18:9 }
(HsTyVar
@@ -247,7 +247,7 @@
(NoExtField)
({ T17544.hs:20:9-16 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ T17544.hs:20:9 }
(HsTyVar
=====================================
testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
=====================================
@@ -85,6 +85,7 @@
(Nothing)
(PrefixCon
[(HsScaled
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ T17544_kw.hs:19:18-19 }
(HsTupleTy
=====================================
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
=====================================
@@ -66,6 +66,7 @@
(Nothing)
(PrefixCon
[(HsScaled
+ (NormalSyntax)
(HsLinearArrow)
({ DumpParsedAst.hs:7:26-30 }
(HsTyVar
@@ -258,6 +259,7 @@
(Nothing)
(PrefixCon
[(HsScaled
+ (NormalSyntax)
(HsLinearArrow)
({ DumpParsedAst.hs:14:25-29 }
(HsParTy
@@ -391,7 +393,7 @@
{OccName: f}))
({ DumpParsedAst.hs:16:31-39 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpParsedAst.hs:16:31 }
(HsTyVar
=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -100,6 +100,7 @@
(Nothing)
(PrefixCon
[(HsScaled
+ (NormalSyntax)
(HsLinearArrow)
({ DumpRenamedAst.hs:9:26-30 }
(HsTyVar
@@ -253,7 +254,7 @@
(NoExtField)
({ DumpRenamedAst.hs:15:20-33 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:15:20 }
(HsTyVar
@@ -263,7 +264,7 @@
{Name: k})))
({ DumpRenamedAst.hs:15:25-33 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:15:25 }
(HsTyVar
@@ -307,7 +308,7 @@
{Name: a})))
({ DumpRenamedAst.hs:18:28-36 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:18:28 }
(HsTyVar
@@ -331,14 +332,14 @@
(Just
({ DumpRenamedAst.hs:18:42-60 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:18:42-52 }
(HsParTy
(NoExtField)
({ DumpRenamedAst.hs:18:43-51 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:18:43 }
(HsTyVar
@@ -370,6 +371,7 @@
(Nothing)
(PrefixCon
[(HsScaled
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:19:10-34 }
(HsParTy
@@ -387,7 +389,7 @@
{Name: xx})))])
({ DumpRenamedAst.hs:19:22-33 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:19:22-25 }
(HsAppTy
@@ -496,6 +498,7 @@
(Nothing)
(PrefixCon
[(HsScaled
+ (NormalSyntax)
(HsLinearArrow)
({ DumpRenamedAst.hs:21:25-29 }
(HsParTy
@@ -619,7 +622,7 @@
{Name: f})
({ DumpRenamedAst.hs:23:31-39 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ DumpRenamedAst.hs:23:31 }
(HsTyVar
=====================================
testsuite/tests/parser/should_compile/KindSigs.stderr
=====================================
@@ -275,7 +275,7 @@
(NoExtField)
({ KindSigs.hs:22:8-44 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ KindSigs.hs:22:8-20 }
(HsParTy
@@ -299,7 +299,7 @@
{OccName: Type}))))))))
({ KindSigs.hs:22:25-44 }
(HsFunTy
- (NoExtField)
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ KindSigs.hs:22:25-28 }
(HsTyVar
=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -42,6 +42,7 @@
(Nothing)
(PrefixCon
[(HsScaled
+ (NormalSyntax)
(HsLinearArrow)
({ T14189.hs:6:18-20 }
(HsTyVar
=====================================
testsuite/tests/printer/T18791.stderr
=====================================
@@ -41,6 +41,7 @@
(Nothing)
(PrefixCon
[(HsScaled
+ (NormalSyntax)
(HsUnrestrictedArrow)
({ T18791.hs:5:10-12 }
(HsTyVar
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 7b5972402afad755cd45aaad1a96aac509e9d5d2
+Subproject commit a7c273efc6848583962f78cc84f97a4725f14b88
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6c8953a125adc241b5e5fdb5c73402d787b470f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6c8953a125adc241b5e5fdb5c73402d787b470f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201009/6fbfaaf3/attachment-0001.html>
More information about the ghc-commits
mailing list