Commit ea736839 authored by Alan Zimmerman's avatar Alan Zimmerman

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
parent 59b08a5d
......@@ -931,22 +931,23 @@ isUnrestricted _ = False
-- | Denotes the type of arrows in the surface language
data HsArrow pass
= HsUnrestrictedArrow
-- ^ a -> b
| HsLinearArrow
-- ^ a %1 -> b
| HsExplicitMult (LHsType pass)
-- ^ 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.
= HsUnrestrictedArrow IsUnicodeSyntax
-- ^ a -> b or a → b
| HsLinearArrow IsUnicodeSyntax
-- ^ a %1 -> b or a %1 → b, or a ⊸ b
| HsExplicitMult IsUnicodeSyntax (LHsType 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.
-- | Convert an arrow into its corresponding multiplicity. In essence this
-- erases the information of whether the programmer wrote an explicit
-- multiplicity or a shorthand.
arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn
arrowToHsType HsUnrestrictedArrow = noLoc manyDataConHsTy
arrowToHsType HsLinearArrow = noLoc oneDataConHsTy
arrowToHsType (HsExplicitMult p) = p
arrowToHsType (HsUnrestrictedArrow _) = noLoc manyDataConHsTy
arrowToHsType (HsLinearArrow _) = noLoc oneDataConHsTy
arrowToHsType (HsExplicitMult _ p) = p
-- | This is used in the syntax. In constructor declaration. It must keep the
-- arrow representation.
......@@ -961,20 +962,23 @@ 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 (HsUnrestrictedArrow NormalSyntax)
hsLinear = HsScaled (HsLinearArrow NormalSyntax)
instance Outputable a => Outputable (HsScaled pass a) where
ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t
ppr t
ppr t
instance
(OutputableBndrId pass) =>
Outputable (HsArrow (GhcPass pass)) where
ppr HsUnrestrictedArrow = parens arrow
ppr HsLinearArrow = parens lollipop
ppr (HsExplicitMult p) = parens (mulArrow (ppr p))
ppr arr = parens (pprHsArrow arr)
-- See #18846
pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc
pprHsArrow (HsUnrestrictedArrow _) = arrow
pprHsArrow (HsLinearArrow _) = lollipop
pprHsArrow (HsExplicitMult _ p) = (mulArrow (ppr p))
{-
Note [Unit tuples]
......@@ -1959,10 +1963,7 @@ ppr_fun_ty :: (OutputableBndrId p)
ppr_fun_ty mult ty1 ty2
= let p1 = ppr_mono_lty ty1
p2 = ppr_mono_lty ty2
arr = case mult of
HsLinearArrow -> lollipop
HsUnrestrictedArrow -> arrow
HsExplicitMult p -> mulArrow (ppr p)
arr = pprHsArrow mult
in
sep [p1, arr <+> p2]
......
......@@ -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
......@@ -538,12 +539,12 @@ nlList exprs = noLoc (ExplicitList noExtField Nothing exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy :: HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
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 a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b)
nlHsParTy t = noLoc (HsParTy noExtField t)
nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p)
......
......@@ -2051,22 +2051,22 @@ 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 noExtField (HsUnrestrictedArrow (toUnicode $2)) $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 noExtField ((unLoc $2) (toUnicode $3)) $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 $1 [mu AnnLollyU $2] -- See Note [GADT decl discards annotations]
>> ams (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) $1 $3)
[mu AnnLollyU $2] }
mult :: { Located (HsArrow GhcPs) }
: PREFIX_PERCENT atype { sLL $1 $> (mkMultTy $2) }
mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }
: PREFIX_PERCENT atype { sLL $1 $> (\u -> mkMultTy u $2) }
btype :: { LHsType GhcPs }
: infixtype {% runPV $1 }
......@@ -3999,6 +3999,9 @@ mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l
toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId
toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a
toUnicode :: Located Token -> IsUnicodeSyntax
toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax
gl :: Located a -> SrcSpan
gl = getLoc
......
......@@ -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
......
......@@ -2617,9 +2617,9 @@ mkLHsOpTy x op y =
let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y
in L loc (mkHsOpTy x op y)
mkMultTy :: LHsType GhcPs -> HsArrow GhcPs
mkMultTy (L _ (HsTyLit _ (HsNumTy _ 1))) = HsLinearArrow
mkMultTy t = HsExplicitMult t
mkMultTy :: IsUnicodeSyntax -> LHsType GhcPs -> HsArrow GhcPs
mkMultTy u (L _ (HsTyLit _ (HsNumTy _ 1))) = HsLinearArrow u
mkMultTy u t = HsExplicitMult u t
-----------------------------------------------------------------------------
-- Token symbols
......
......@@ -980,10 +980,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
......
......@@ -624,11 +624,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)
......@@ -721,10 +721,10 @@ rnHsTyKi env (HsWildCardTy _)
; return (HsWildCardTy noExtField, emptyFVs) }
rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow _env HsUnrestrictedArrow = return (HsUnrestrictedArrow, emptyFVs)
rnHsArrow _env HsLinearArrow = return (HsLinearArrow, emptyFVs)
rnHsArrow env (HsExplicitMult p)
= (\(mult, fvs) -> (HsExplicitMult mult, fvs)) <$> rnLHsTyKi env p
rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs)
rnHsArrow _env (HsLinearArrow u) = return (HsLinearArrow u, emptyFVs)
rnHsArrow env (HsExplicitMult u p)
= (\(mult, fvs) -> (HsExplicitMult u mult, fvs)) <$> rnLHsTyKi env p
--------------
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
......@@ -1847,7 +1847,7 @@ extract_lty (L _ ty) acc
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
......
......@@ -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 )
......@@ -1046,7 +1047,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 ty1 ty2 exp_kind
= tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind
--------- Foralls
tc_hs_type mode forall@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind
......
......@@ -2453,7 +2453,7 @@ getGhciStepIO = do
{ hst_tele = mkHsForAllInvisTele
[noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)]
, hst_xforall = noExtField
, hst_body = nlHsFunTy HsUnrestrictedArrow ghciM ioM }
, hst_body = nlHsFunTy ghciM ioM }
stepTy :: LHsSigWcType GhcRn
stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
......
......@@ -3416,7 +3416,7 @@ tcConArg exp_kind (HsScaled w bty)
; return (Scaled w' arg_ty, getBangStrictness bty) }
tcDataConMult :: HsArrow GhcRn -> TcM Mult
tcDataConMult arr@HsUnrestrictedArrow = do
tcDataConMult arr@(HsUnrestrictedArrow _) = do
-- See Note [Function arrows in GADT constructors]
linearEnabled <- xoptM LangExt.LinearTypes
if linearEnabled then tcMult arr else return oneDataConTy
......
......@@ -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 noExtField (HsUnrestrictedArrow NormalSyntax) x'' y'')
| otherwise
-> mk_apps
(HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon)))
......@@ -1623,9 +1624,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
| n == manyDataConName -> HsUnrestrictedArrow
_ -> HsExplicitMult w
| n == oneDataConName -> HsLinearArrow NormalSyntax
| n == manyDataConName -> HsUnrestrictedArrow NormalSyntax
_ -> HsExplicitMult NormalSyntax w
-- ConT/InfixT can contain both data constructor (i.e., promoted) names and
-- other (i.e, unpromoted) names, as opposed to PromotedT, which can only
......
......@@ -1683,7 +1683,7 @@ defineMacro overwrite s = do
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
`mkHsApp` (nlHsPar expr)
tySig = mkLHsSigWcType (nlHsFunTy HsUnrestrictedArrow stringTy ioM)
tySig = mkLHsSigWcType (nlHsFunTy stringTy ioM)
new_expr = L (getLoc expr) $ ExprWithTySig noExtField body tySig
hv <- GHC.compileParsedExprRemote new_expr
......@@ -1751,7 +1751,7 @@ getGhciStepIO = do
ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar (getRdrName ghciStepIoMName)
tySig = mkLHsSigWcType (nlHsFunTy HsUnrestrictedArrow ghciM ioM)
tySig = mkLHsSigWcType (nlHsFunTy ghciM ioM)
return $ noLoc $ ExprWithTySig noExtField body tySig
-----------------------------------------------------------------------------
......
......@@ -44,7 +44,8 @@
({ T17544.hs:6:9-16 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ T17544.hs:6:9 }
(HsTyVar
(NoExtField)
......@@ -104,7 +105,8 @@
({ T17544.hs:10:9-16 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ T17544.hs:10:9 }
(HsTyVar
(NoExtField)
......@@ -161,7 +163,8 @@
({ T17544.hs:14:9-16 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ T17544.hs:14:9 }
(HsTyVar
(NoExtField)
......@@ -221,7 +224,8 @@
({ T17544.hs:18:9-16 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ T17544.hs:18:9 }
(HsTyVar
(NoExtField)
......@@ -248,7 +252,8 @@
({ T17544.hs:20:9-16 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ T17544.hs:20:9 }
(HsTyVar
(NoExtField)
......
......@@ -85,7 +85,8 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ T17544_kw.hs:19:18-19 }
(HsTupleTy
(NoExtField)
......
......@@ -66,7 +66,8 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsLinearArrow)
(HsLinearArrow
(NormalSyntax))
({ DumpParsedAst.hs:7:26-30 }
(HsTyVar
(NoExtField)
......@@ -258,7 +259,8 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsLinearArrow)
(HsLinearArrow
(NormalSyntax))
({ DumpParsedAst.hs:14:25-29 }
(HsParTy
(NoExtField)
......@@ -392,7 +394,8 @@
({ DumpParsedAst.hs:16:31-39 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpParsedAst.hs:16:31 }
(HsTyVar
(NoExtField)
......
......@@ -100,7 +100,8 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsLinearArrow)
(HsLinearArrow
(NormalSyntax))
({ DumpRenamedAst.hs:9:26-30 }
(HsTyVar
(NoExtField)
......@@ -254,7 +255,8 @@
({ DumpRenamedAst.hs:15:20-33 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpRenamedAst.hs:15:20 }
(HsTyVar
(NoExtField)
......@@ -264,7 +266,8 @@
({ DumpRenamedAst.hs:15:25-33 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpRenamedAst.hs:15:25 }
(HsTyVar
(NoExtField)
......@@ -308,7 +311,8 @@
({ DumpRenamedAst.hs:18:28-36 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpRenamedAst.hs:18:28 }
(HsTyVar
(NoExtField)
......@@ -332,14 +336,16 @@
({ DumpRenamedAst.hs:18:42-60 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpRenamedAst.hs:18:42-52 }
(HsParTy
(NoExtField)
({ DumpRenamedAst.hs:18:43-51 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpRenamedAst.hs:18:43 }
(HsTyVar
(NoExtField)
......@@ -370,7 +376,8 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpRenamedAst.hs:19:10-34 }
(HsParTy
(NoExtField)
......@@ -388,7 +395,8 @@
({ DumpRenamedAst.hs:19:22-33 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpRenamedAst.hs:19:22-25 }
(HsAppTy
(NoExtField)
......@@ -496,7 +504,8 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsLinearArrow)
(HsLinearArrow
(NormalSyntax))
({ DumpRenamedAst.hs:21:25-29 }
(HsParTy
(NoExtField)
......@@ -620,7 +629,8 @@
({ DumpRenamedAst.hs:23:31-39 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ DumpRenamedAst.hs:23:31 }
(HsTyVar
(NoExtField)
......
......@@ -276,7 +276,8 @@
({ KindSigs.hs:22:8-44 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ KindSigs.hs:22:8-20 }
(HsParTy
(NoExtField)
......@@ -300,7 +301,8 @@
({ KindSigs.hs:22:25-44 }
(HsFunTy
(NoExtField)
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ KindSigs.hs:22:25-28 }
(HsTyVar
(NoExtField)
......
......@@ -42,7 +42,8 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsLinearArrow)
(HsLinearArrow
(NormalSyntax))
({ T14189.hs:6:18-20 }
(HsTyVar
(NoExtField)
......
......@@ -41,7 +41,8 @@
(Nothing)
(PrefixCon
[(HsScaled
(HsUnrestrictedArrow)
(HsUnrestrictedArrow
(NormalSyntax))
({ T18791.hs:5:10-12 }
(HsTyVar
(NoExtField)
......
Subproject commit 77261e89c31b41eb5d7f1d16bb1de5b14b4296f4
Subproject commit a7d1d8e034d25612d5d08ed8fdbf6f472aded4a1
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