HsUniToken and HsToken for HsArrow (#19623)

Another step towards a simpler design for exact printing.

Updates the haddock submodule.

21 files changed, 110 insertions, 80 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