diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index cc5cfb159c806496b984149ccd225c40f360f172..0f5927453343480f97913fd619fdd03cc02f4c11 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -1306,12 +1306,8 @@ type instance XXRuleDecl (GhcPass _) = DataConCantHappen
data HsRuleAnn
= HsRuleAnn
- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)
- -- ^ The locations of 'forall' and '.' for forall'd type vars
- -- Using AddEpAnn to capture possible unicode variants
- , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)
- -- ^ The locations of 'forall' and '.' for forall'd term vars
- -- Using AddEpAnn to capture possible unicode variants
+ { ra_tyanns :: Maybe (TokForall, EpToken ".")
+ , ra_tmanns :: Maybe (TokForall, EpToken ".")
, ra_equal :: EpToken "="
, ra_rest :: ActivationAnn
} deriving (Data, Eq)
diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs
index 8c21c3f94a9bad3a682cc3c43dbe3567602f43bc..5ac4cb688ab1973cb165f47a86ab60bdd37866f3 100644
--- a/compiler/GHC/Hs/Dump.hs
+++ b/compiler/GHC/Hs/Dump.hs
@@ -59,7 +59,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
showAstData' =
generic
`ext1Q` list
- `extQ` list_addEpAnn
`extQ` list_epaLocation
`extQ` list_epTokenOpenP
`extQ` list_epTokenCloseP
@@ -116,12 +115,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
bytestring :: B.ByteString -> SDoc
bytestring = text . normalize_newlines . show
- list_addEpAnn :: [AddEpAnn] -> SDoc
- list_addEpAnn ls = case ba of
- BlankEpAnnotations -> parens
- $ text "blanked:" <+> text "[AddEpAnn]"
- NoBlankEpAnnotations -> list ls
-
list_epaLocation :: [EpaLocation] -> SDoc
list_epaLocation ls = case ba of
BlankEpAnnotations -> parens
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 08abb0b9bd2731f14b5033928e1ec1296f762055..edf00ebfdb96f93b57b05499c804e3f8e8e362b1 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1335,7 +1335,7 @@ names 'getField' and 'setField' are whatever in-scope names they are.
************************************************************************
-}
-type instance XCmdArrApp GhcPs = AddEpAnn
+type instance XCmdArrApp GhcPs = (IsUnicodeSyntax, EpaLocation)
type instance XCmdArrApp GhcRn = NoExtField
type instance XCmdArrApp GhcTc = Type
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index b5e1336384654d558b16e0d78cdf2754f50fb203..82ee60810336abd878726e5e88cde445b61bf6c2 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -838,14 +838,10 @@ litpkgname_segment :: { Located FastString }
-- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.
-- See Note [Minus tokens] in GHC.Parser.Lexer
-HYPHEN :: { [AddEpAnn] }
- : '-' { [mj AnnMinus $1 ] }
- | PREFIX_MINUS { [mj AnnMinus $1 ] }
- | VARSYM {% if (getVARSYM $1 == fsLit "-")
- then return [mj AnnMinus $1]
- else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $ PsErrExpectedHyphen
- ; return [] } }
-
+HYPHEN :: { () }
+ : '-' { () }
+ | PREFIX_MINUS { () }
+ | VARSYM { () }
litpkgname :: { Located FastString }
: litpkgname_segment { $1 }
@@ -1974,11 +1970,11 @@ rule_foralls :: { (EpToken "=" -> ActivationAnn -> HsRuleAnn, Maybe [LHsTyVarBnd
in hintExplicitForall $1
>> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)
>> return (\an_eq an_act -> HsRuleAnn
- (Just (mu AnnForall $1,mj AnnDot $3))
- (Just (mu AnnForall $4,mj AnnDot $6))
+ (Just (epUniTok $1,epTok $3))
+ (Just (epUniTok $4,epTok $6))
an_eq an_act,
Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }
- | 'forall' rule_vars '.' { (\an_eq an_act -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) an_eq an_act,
+ | 'forall' rule_vars '.' { (\an_eq an_act -> HsRuleAnn Nothing (Just (epUniTok $1,epTok $3)) an_eq an_act,
Nothing, mkRuleBndrs $2) }
-- See Note [%shift: rule_foralls -> {- empty -}]
| {- empty -} %shift { (\an_eq an_act -> HsRuleAnn Nothing Nothing an_eq an_act, Nothing, []) }
@@ -2824,25 +2820,25 @@ exp_gen(IEXP) :: { ECP }
{% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- amsA' (sLL $1 $> $ HsCmdArrApp (mu Annlarrowtail $2) $1 $3
+ amsA' (sLL $1 $> $ HsCmdArrApp (isUnicodeSyntax $2, glR $2) $1 $3
HsFirstOrderApp True) }
| IEXP '>-' exp_gen(IEXP)
{% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- amsA' (sLL $1 $> $ HsCmdArrApp (mu Annrarrowtail $2) $3 $1
+ amsA' (sLL $1 $> $ HsCmdArrApp (isUnicodeSyntax $2, glR $2) $3 $1
HsFirstOrderApp False) }
| IEXP '-<<' exp_gen(IEXP)
{% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- amsA' (sLL $1 $> $ HsCmdArrApp (mu AnnLarrowtail $2) $1 $3
+ amsA' (sLL $1 $> $ HsCmdArrApp (isUnicodeSyntax $2, glR $2) $1 $3
HsHigherOrderApp True) }
| IEXP '>>-' exp_gen(IEXP)
{% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- amsA' (sLL $1 $> $ HsCmdArrApp (mu AnnRarrowtail $2) $3 $1
+ amsA' (sLL $1 $> $ HsCmdArrApp (isUnicodeSyntax $2, glR $2) $3 $1
HsHigherOrderApp False) }
-- See Note [%shift: exp -> infixexp]
| IEXP %shift { $1 }
@@ -4726,7 +4722,7 @@ addTrailingCommaN (L anns a) span = do
addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral
addTrailingCommaS (L l sl) span
- = L (widenSpan l [AddEpAnn AnnComma span]) (sl { sl_tc = Just (epaToNoCommentsLocation span) })
+ = L (widenSpanL l [span]) (sl { sl_tc = Just (epaToNoCommentsLocation span) })
-- -------------------------------------
@@ -4738,6 +4734,9 @@ addTrailingDarrowC (L (EpAnn lr (AnnContext _ o c) csc) a) lt cs =
-- -------------------------------------
+isUnicodeSyntax :: Located Token -> IsUnicodeSyntax
+isUnicodeSyntax lt = if isUnicode lt then UnicodeSyntax else NormalSyntax
+
-- We need a location for the where binds, when computing the SrcSpan
-- for the AST element using them. Where there is a span, we return
-- it, else noLoc, which is ignored in the comb2 call.
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 05c8ed25c8ceec9d8bd79870646bb30cd7530557..2f76b721f7577d899893ba5dad34fdac9ad1870e 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -69,13 +69,12 @@ module GHC.Parser.Annotation (
-- ** Building up annotations
reAnnL, reAnnC,
- addAnns, addAnnsA, widenSpan, widenSpanL, widenSpanT, widenAnchor, widenAnchorT, widenAnchorS,
- widenLocatedAn, widenLocatedAnL,
+ addAnnsA, widenSpanL, widenSpanT, widenAnchorT, widenAnchorS,
+ widenLocatedAnL,
listLocation,
-- ** Querying annotations
getLocAnn,
- annParen2AddEpAnn,
epAnnComments,
-- ** Working with locations of annotations
@@ -1114,25 +1113,11 @@ reAnnL anns cs (L l a) = L (EpAnn (spanAsAnchor l) anns cs) a
getLocAnn :: Located a -> SrcSpanAnnA
getLocAnn (L l _) = noAnnSrcSpan l
-addAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]
-addAnns (EpAnn l as1 cs) as2 cs2
- = EpAnn (widenAnchor l (as1 ++ as2)) (as1 ++ as2) (cs <> cs2)
-
-- AZ:TODO use widenSpan here too
addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA
addAnnsA (EpAnn l as1 cs) as2 cs2
= EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)
--- | The annotations need to all come after the anchor. Make sure
--- this is the case.
-widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan
-widenSpan s as = foldl combineSrcSpans s (go as)
- where
- go [] = []
- go (AddEpAnn _ (EpaSpan (RealSrcSpan s mb)):rest) = RealSrcSpan s mb : go rest
- go (AddEpAnn _ (EpaSpan _):rest) = go rest
- go (AddEpAnn _ (EpaDelta _ _ _):rest) = go rest
-
-- | The annotations need to all come after the anchor. Make sure
-- this is the case.
widenSpanL :: SrcSpan -> [EpaLocation] -> SrcSpan
@@ -1147,35 +1132,6 @@ widenSpanT :: SrcSpan -> EpToken tok -> SrcSpan
widenSpanT l (EpTok loc) = widenSpanL l [loc]
widenSpanT l NoEpTok = l
--- | The annotations need to all come after the anchor. Make sure
--- this is the case.
-widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan
-widenRealSpan s as = foldl combineRealSrcSpans s (go as)
- where
- go [] = []
- go (AddEpAnn _ (EpaSpan (RealSrcSpan s _)):rest) = s : go rest
- go (AddEpAnn _ _:rest) = go rest
-
-realSpanFromAnns :: [AddEpAnn] -> Strict.Maybe RealSrcSpan
-realSpanFromAnns as = go Strict.Nothing as
- where
- combine Strict.Nothing r = Strict.Just r
- combine (Strict.Just l) r = Strict.Just $ combineRealSrcSpans l r
-
- go acc [] = acc
- go acc (AddEpAnn _ (EpaSpan (RealSrcSpan s _b)):rest) = go (combine acc s) rest
- go acc (AddEpAnn _ _ :rest) = go acc rest
-
-bufSpanFromAnns :: [AddEpAnn] -> Strict.Maybe BufSpan
-bufSpanFromAnns as = go Strict.Nothing as
- where
- combine Strict.Nothing r = Strict.Just r
- combine (Strict.Just l) r = Strict.Just $ combineBufSpans l r
-
- go acc [] = acc
- go acc (AddEpAnn _ (EpaSpan (RealSrcSpan _ (Strict.Just mb))):rest) = go (combine acc mb) rest
- go acc (AddEpAnn _ _:rest) = go acc rest
-
listLocation :: [LocatedAn an a] -> EpaLocation
listLocation as = EpaSpan (go noSrcSpan as)
where
@@ -1185,14 +1141,6 @@ listLocation as = EpaSpan (go noSrcSpan as)
go acc (L (EpAnn (EpaSpan s) _ _) _:rest) = go (combine acc s) rest
go acc (_:rest) = go acc rest
-widenAnchor :: EpaLocation -> [AddEpAnn] -> EpaLocation
-widenAnchor (EpaSpan (RealSrcSpan s mb)) as
- = EpaSpan (RealSrcSpan (widenRealSpan s as) (liftA2 combineBufSpans mb (bufSpanFromAnns as)))
-widenAnchor (EpaSpan us) _ = EpaSpan us
-widenAnchor a@EpaDelta{} as = case (realSpanFromAnns as) of
- Strict.Nothing -> a
- Strict.Just r -> EpaSpan (RealSrcSpan r Strict.Nothing)
-
widenAnchorT :: EpaLocation -> EpToken tok -> EpaLocation
widenAnchorT (EpaSpan ss) (EpTok l) = widenAnchorS l ss
widenAnchorT ss _ = ss
@@ -1204,24 +1152,12 @@ widenAnchorS (EpaSpan us) _ = EpaSpan us
widenAnchorS EpaDelta{} (RealSrcSpan r mb) = EpaSpan (RealSrcSpan r mb)
widenAnchorS anc _ = anc
-widenLocatedAn :: EpAnn an -> [AddEpAnn] -> EpAnn an
-widenLocatedAn (EpAnn (EpaSpan l) a cs) as = EpAnn (spanAsAnchor l') a cs
- where
- l' = widenSpan l as
-widenLocatedAn (EpAnn anc a cs) _as = EpAnn anc a cs
-
widenLocatedAnL :: EpAnn an -> [EpaLocation] -> EpAnn an
widenLocatedAnL (EpAnn (EpaSpan l) a cs) as = EpAnn (spanAsAnchor l') a cs
where
l' = widenSpanL l as
widenLocatedAnL (EpAnn anc a cs) _as = EpAnn anc a cs
-annParen2AddEpAnn :: AnnParen -> [AddEpAnn]
-annParen2AddEpAnn (AnnParen pt o c)
- = [AddEpAnn ai o, AddEpAnn ac c]
- where
- (ai,ac) = parenTypeKws pt
-
epAnnComments :: EpAnn an -> EpAnnComments
epAnnComments (EpAnn _ _ cs) = cs
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index ec035542168aaaeade4170f7ddb3666466f1a24e..791ad3fccb32e15a4ab77dad7145f09aa5ae89c5 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -984,7 +984,7 @@ checkTyVars pp_what equals_or_where tc tparms
= Just (noAnn, HsBndrWildCard noExtField)
match_bndr_var _ = Nothing
- -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.
+ -- Return an AddEpAnn for use in widenLocatedAnL. The AnnKeywordId is not used.
for_widening :: HsBndrVis GhcPs -> EpaLocation
for_widening (HsBndrInvisible (EpTok loc)) = loc
for_widening _ = noAnn
@@ -1524,9 +1524,7 @@ isFunLhs e = go e [] [] []
go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps
= go (L lp' pat) (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps
where invis_pat = InvisPat (tok, SpecifiedSpec) ty_pat
- anc' = case tok of
- NoEpTok -> anc
- EpTok l -> widenAnchor anc [AddEpAnn AnnAnyclass l]
+ anc' = widenAnchorT anc tok
(_l, lp') = transferCommentsOnlyA l lp
go _ _ _ _ = return Nothing
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 0b42bae688c2f28b264707aa01bf88d2a49e35b4..f17ccaa9040a6723ea36d508b16f537e505d161c 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -268,10 +268,6 @@ instance HasTrailing AddEpAnn where
trailing _ = []
setTrailing a _ = a
-instance HasTrailing [AddEpAnn] where
- trailing _ = []
- setTrailing a _ = a
-
instance HasTrailing (AddEpAnn, AddEpAnn) where
trailing _ = []
setTrailing a _ = a
@@ -1025,10 +1021,6 @@ lal_rest k parent = fmap (\new -> parent { al_rest = new })
-- -------------------------------------
-lidl :: Lens [AddEpAnn] [AddEpAnn]
-lidl k parent = fmap (\new -> new)
- (k parent)
-
lid :: Lens a a
lid k parent = fmap (\new -> new)
(k parent)
@@ -1156,17 +1148,13 @@ lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new })
-- data HsRuleAnn
-- = HsRuleAnn
--- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)
--- -- ^ The locations of 'forall' and '.' for forall'd type vars
--- -- Using AddEpAnn to capture possible unicode variants
--- , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)
--- -- ^ The locations of 'forall' and '.' for forall'd term vars
--- -- Using AddEpAnn to capture possible unicode variants
+-- { ra_tyanns :: Maybe (TokForall, EpToken ".")
+-- , ra_tmanns :: Maybe (TokForall, EpToken ".")
-- , ra_equal :: EpToken "="
-- , ra_rest :: ActivationAnn
-- } deriving (Data, Eq)
-lra_tyanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn))
+lra_tyanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken "."))
lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new })
(k (ra_tyanns parent))
@@ -1185,20 +1173,20 @@ lff k parent = fmap (\new -> gg new)
(k (ff parent))
-- (.) :: Lens' a b -> Lens' b c -> Lens' a c
-lra_tyanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tyanns_fst :: Lens HsRuleAnn (Maybe TokForall)
lra_tyanns_fst = lra_tyanns . lff . lfst
-lra_tyanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tyanns_snd :: Lens HsRuleAnn (Maybe (EpToken "."))
lra_tyanns_snd = lra_tyanns . lff . lsnd
-lra_tmanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn))
+lra_tmanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken "."))
lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new })
(k (ra_tmanns parent))
-lra_tmanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tmanns_fst :: Lens HsRuleAnn (Maybe TokForall)
lra_tmanns_fst = lra_tmanns . lff . lfst
-lra_tmanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tmanns_snd :: Lens HsRuleAnn (Maybe (EpToken "."))
lra_tmanns_snd = lra_tmanns . lff . lsnd
lra_equal :: Lens HsRuleAnn (EpToken "=")
@@ -1304,22 +1292,8 @@ markLensTok (EpAnn anc a cs) l = do
new <- markEpToken (view l a)
return (EpAnn anc (set l new a) cs)
-markLensTok' :: (Monad m, Monoid w, KnownSymbol sym)
- => a -> Lens a (EpToken sym) -> EP w m a
-markLensTok' a l = do
- new <- markEpToken (view l a)
- return (set l new a)
-
-- ---------------------------------------------------------------------
-markEpAnnL :: (Monad m, Monoid w)
- => ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m ann
-markEpAnnL a l kw = do
- anns <- mark (view l a) kw
- return (set l anns a)
-
--- -------------------------------------
-
markLensFun' :: (Monad m, Monoid w)
=> EpAnn ann -> Lens ann t -> (t -> EP w m t) -> EP w m (EpAnn ann)
markLensFun' epann l f = markLensFun epann (lepa . l) f
@@ -1895,46 +1869,36 @@ instance ExactPrint (InstDecl GhcPs) where
cid' <- markAnnotated cid
return (ClsInstD a cid')
exact (DataFamInstD a decl) = do
- d' <- markAnnotated (DataFamInstDeclWithContext noAnn TopLevel decl)
- return (DataFamInstD a (dc_d d'))
+ decl' <- markAnnotated decl
+ return (DataFamInstD a decl')
exact (TyFamInstD a eqn) = do
eqn' <- markAnnotated eqn
return (TyFamInstD a eqn')
-- ---------------------------------------------------------------------
-data DataFamInstDeclWithContext
- = DataFamInstDeclWithContext
- { _dc_a :: [AddEpAnn]
- , _dc_f :: TopLevelFlag
- , dc_d :: DataFamInstDecl GhcPs
- }
-
-instance ExactPrint DataFamInstDeclWithContext where
+instance ExactPrint (DataFamInstDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (DataFamInstDeclWithContext an c d) = do
- debugM $ "starting DataFamInstDeclWithContext:an=" ++ showAst an
- (an', d') <- exactDataFamInstDecl an c d
- return (DataFamInstDeclWithContext an' c d')
+ exact d = do
+ d' <- exactDataFamInstDecl d
+ return d'
-- ---------------------------------------------------------------------
exactDataFamInstDecl :: (Monad m, Monoid w)
- => [AddEpAnn] -> TopLevelFlag -> DataFamInstDecl GhcPs
- -> EP w m ([AddEpAnn], DataFamInstDecl GhcPs)
-exactDataFamInstDecl an top_lvl
+ => DataFamInstDecl GhcPs
+ -> EP w m (DataFamInstDecl GhcPs)
+exactDataFamInstDecl
(DataFamInstDecl (FamEqn { feqn_ext = (ops, cps, eq)
, feqn_tycon = tycon
, feqn_bndrs = bndrs
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = defn })) = do
- ((ops', cps', an'), tycon', bndrs', pats', defn') <- exactDataDefn pp_hdr defn
- -- See Note [an and an2 in exactDataFamInstDecl]
+ ((ops', cps'), tycon', bndrs', pats', defn') <- exactDataDefn pp_hdr defn
return
- (an',
- DataFamInstDecl ( FamEqn { feqn_ext = (ops', cps', eq)
+ (DataFamInstDecl ( FamEqn { feqn_ext = (ops', cps', eq)
, feqn_tycon = tycon'
, feqn_bndrs = bndrs'
, feqn_pats = pats'
@@ -1944,28 +1908,12 @@ exactDataFamInstDecl an top_lvl
where
pp_hdr :: (Monad m, Monoid w)
=> Maybe (LHsContext GhcPs)
- -> EP w m ( ([EpToken "("], [EpToken ")"], [AddEpAnn])
+ -> EP w m ( ([EpToken "("], [EpToken ")"] )
, LocatedN RdrName
, HsOuterTyVarBndrs () GhcPs
, HsFamEqnPats GhcPs
, Maybe (LHsContext GhcPs))
- pp_hdr mctxt = do
- an0 <- case top_lvl of
- TopLevel -> markEpAnnL an lidl AnnInstance -- TODO: maybe in toplevel
- NotTopLevel -> return an
- exactHsFamInstLHS ops cps an0 tycon bndrs pats fixity mctxt
-
-{-
-Note [an and an2 in exactDataFamInstDecl]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The exactDataFamInstDecl function is called to render a
-DataFamInstDecl within its surrounding context. This context is
-rendered via the 'pp_hdr' function, which uses the exact print
-annotations from that context, named 'an'. The EPAs used for
-rendering the DataDefn are contained in the FamEqn, and are called
-'an2'.
-
--}
+ pp_hdr mctxt = exactHsFamInstLHS ops cps tycon bndrs pats fixity mctxt
-- ---------------------------------------------------------------------
@@ -2152,17 +2100,17 @@ instance ExactPrint (RuleDecl GhcPs) where
case mtybndrs of
Nothing -> return (an0, Nothing)
Just bndrs -> do
- an1 <- markLensMAA' an0 lra_tyanns_fst -- AnnForall
+ an1 <- markLensFun an0 lra_tyanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall
bndrs' <- mapM markAnnotated bndrs
- an2 <- markLensMAA' an1 lra_tyanns_snd -- AnnDot
+ an2 <- markLensFun an1 lra_tyanns_snd (\mt -> mapM markEpToken mt) -- AnnDot
return (an2, Just bndrs')
- an2 <- markLensMAA' an1 lra_tmanns_fst -- AnnForall
+ an2 <- markLensFun an1 lra_tmanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall
termbndrs' <- mapM markAnnotated termbndrs
- an3 <- markLensMAA' an2 lra_tmanns_snd -- AnnDot
+ an3 <- markLensFun an2 lra_tmanns_snd (\mt -> mapM markEpToken mt) -- AnnDot
lhs' <- markAnnotated lhs
- an4 <- markLensTok' an3 lra_equal
+ an4 <- markLensFun an3 lra_equal markEpToken
rhs' <- markAnnotated rhs
return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs')
@@ -2268,10 +2216,10 @@ instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where
, feqn_pats = pats
, feqn_fixity = fixity
, feqn_rhs = rhs }) = do
- (_an0, tycon', bndrs', pats', _) <- exactHsFamInstLHS ops cps [] tycon bndrs pats fixity Nothing
+ ((ops', cps'), tycon', bndrs', pats',_) <- exactHsFamInstLHS ops cps tycon bndrs pats fixity Nothing
eq' <- markEpToken eq
rhs' <- markAnnotated rhs
- return (FamEqn { feqn_ext = ([], [], eq')
+ return (FamEqn { feqn_ext = (ops', cps', eq')
, feqn_tycon = tycon'
, feqn_bndrs = bndrs'
, feqn_pats = pats'
@@ -2284,24 +2232,23 @@ exactHsFamInstLHS ::
(Monad m, Monoid w)
=> [EpToken "("]
-> [EpToken ")"]
- -> [AddEpAnn]
-> LocatedN RdrName
-> HsOuterTyVarBndrs () GhcPs
-> HsFamEqnPats GhcPs
-> LexicalFixity
-> Maybe (LHsContext GhcPs)
- -> EP w m ( ([EpToken "("], [EpToken ")"], [AddEpAnn])
+ -> EP w m ( ([EpToken "("], [EpToken ")"])
, LocatedN RdrName
, HsOuterTyVarBndrs () GhcPs
, HsFamEqnPats GhcPs, Maybe (LHsContext GhcPs))
-exactHsFamInstLHS ops cps an thing bndrs typats fixity mb_ctxt = do
+exactHsFamInstLHS ops cps thing bndrs typats fixity mb_ctxt = do
-- TODO:AZ: do these ans exist? They are in the binders now
- an0 <- markEpAnnL an lidl AnnForall
+ -- an0 <- markEpAnnL an lidl AnnForall
bndrs' <- markAnnotated bndrs
- an1 <- markEpAnnL an0 lidl AnnDot
+ -- an1 <- markEpAnnL an0 lidl AnnDot
mb_ctxt' <- mapM markAnnotated mb_ctxt
(ops', cps', thing', typats') <- exact_pats ops cps typats
- return ((ops', cps', an1), thing', bndrs', typats', mb_ctxt')
+ return ((ops', cps'), thing', bndrs', typats', mb_ctxt')
where
exact_pats :: (Monad m, Monoid w)
=> [EpToken "("] -> [EpToken ")"] -> HsFamEqnPats GhcPs
@@ -2730,8 +2677,8 @@ prepareListAnnotationF :: (Monad m, Monoid w) =>
prepareListAnnotationF ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls
where
go (L l a) = do
- (L l' d') <- markAnnotated (L l (DataFamInstDeclWithContext noAnn NotTopLevel a))
- return (toDyn (L l' (dc_d d')))
+ (L l' d') <- markAnnotated (L l a)
+ return (toDyn (L l' d'))
prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAn an a))
=> [LocatedAn an a] -> [(RealSrcSpan,EP w m Dynamic)]
@@ -3498,18 +3445,34 @@ instance ExactPrint (HsCmd GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsCmdArrApp an arr arg o isRightToLeft) = do
- if isRightToLeft
- then do
- arr' <- markAnnotated arr
- an0 <- markKw an
- arg' <- markAnnotated arg
- return (HsCmdArrApp an0 arr' arg' o isRightToLeft)
- else do
- arg' <- markAnnotated arg
- an0 <- markKw an
- arr' <- markAnnotated arr
- return (HsCmdArrApp an0 arr' arg' o isRightToLeft)
+ exact (HsCmdArrApp (isU, l) arr arg HsFirstOrderApp True) = do
+ arr' <- markAnnotated arr
+ l' <- case isU of
+ UnicodeSyntax -> printStringAtAA l "⤙"
+ NormalSyntax -> printStringAtAA l "-<"
+ arg' <- markAnnotated arg
+ return (HsCmdArrApp (isU, l') arr' arg' HsFirstOrderApp True)
+ exact (HsCmdArrApp (isU, l) arr arg HsFirstOrderApp False) = do
+ arg' <- markAnnotated arg
+ l' <- case isU of
+ UnicodeSyntax -> printStringAtAA l "⤚"
+ NormalSyntax -> printStringAtAA l ">-"
+ arr' <- markAnnotated arr
+ return (HsCmdArrApp (isU, l') arr' arg' HsFirstOrderApp False)
+ exact (HsCmdArrApp (isU, l) arr arg HsHigherOrderApp True) = do
+ arr' <- markAnnotated arr
+ l' <- case isU of
+ UnicodeSyntax -> printStringAtAA l "⤛"
+ NormalSyntax -> printStringAtAA l "-<<"
+ arg' <- markAnnotated arg
+ return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp True)
+ exact (HsCmdArrApp (isU, l) arr arg HsHigherOrderApp False) = do
+ arg' <- markAnnotated arg
+ l' <- case isU of
+ UnicodeSyntax -> printStringAtAA l "⤜"
+ NormalSyntax -> printStringAtAA l ">>-"
+ arr' <- markAnnotated arr
+ return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp False)
exact (HsCmdArrForm an e fixity cs) = do
an0 <- markLensMAA' an lal_open
@@ -3891,7 +3854,7 @@ exactDataDefn exactHdr
nt' <- markEpToken nt
return (t, nt', d)
- i' <- markEpToken i -- optional
+ i' <- markEpToken i -- optional 'instance'
mb_ct' <- mapM markAnnotated mb_ct
(anx, ln', tvs', b, mctxt') <- exactHdr context
(dc', mb_sig') <- case mb_sig of
diff --git a/utils/haddock/haddock-api/src/Haddock/Types.hs b/utils/haddock/haddock-api/src/Haddock/Types.hs
index f71a3f04aeea0bfdf7071f01f8428a319ccf9ac7..bf67ea8af56b165b8861f58e9f6922a13ed6a0f8 100644
--- a/utils/haddock/haddock-api/src/Haddock/Types.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Types.hs
@@ -842,28 +842,28 @@ type instance XLinearArrow _ DocNameI = NoExtField
type instance XExplicitMult _ DocNameI = NoExtField
type instance XXArrow _ DocNameI = DataConCantHappen
-type instance XForAllTy DocNameI = EpAnn [AddEpAnn]
-type instance XQualTy DocNameI = EpAnn [AddEpAnn]
-type instance XTyVar DocNameI = EpAnn [AddEpAnn]
-type instance XStarTy DocNameI = EpAnn [AddEpAnn]
-type instance XAppTy DocNameI = EpAnn [AddEpAnn]
-type instance XAppKindTy DocNameI = EpAnn [AddEpAnn]
-type instance XFunTy DocNameI = EpAnn [AddEpAnn]
+type instance XForAllTy DocNameI = EpAnn NoEpAnns
+type instance XQualTy DocNameI = EpAnn NoEpAnns
+type instance XTyVar DocNameI = EpAnn NoEpAnns
+type instance XStarTy DocNameI = EpAnn NoEpAnns
+type instance XAppTy DocNameI = EpAnn NoEpAnns
+type instance XAppKindTy DocNameI = EpAnn NoEpAnns
+type instance XFunTy DocNameI = EpAnn NoEpAnns
type instance XListTy DocNameI = EpAnn AnnParen
type instance XTupleTy DocNameI = EpAnn AnnParen
type instance XSumTy DocNameI = EpAnn AnnParen
-type instance XOpTy DocNameI = EpAnn [AddEpAnn]
+type instance XOpTy DocNameI = EpAnn NoEpAnns
type instance XParTy DocNameI = (EpToken "(", EpToken ")")
-type instance XIParamTy DocNameI = EpAnn [AddEpAnn]
-type instance XKindSig DocNameI = EpAnn [AddEpAnn]
+type instance XIParamTy DocNameI = EpAnn NoEpAnns
+type instance XKindSig DocNameI = EpAnn NoEpAnns
type instance XSpliceTy DocNameI = DataConCantHappen
-type instance XDocTy DocNameI = EpAnn [AddEpAnn]
-type instance XBangTy DocNameI = EpAnn [AddEpAnn]
-type instance XRecTy DocNameI = EpAnn [AddEpAnn]
-type instance XExplicitListTy DocNameI = EpAnn [AddEpAnn]
-type instance XExplicitTupleTy DocNameI = EpAnn [AddEpAnn]
-type instance XTyLit DocNameI = EpAnn [AddEpAnn]
-type instance XWildCardTy DocNameI = EpAnn [AddEpAnn]
+type instance XDocTy DocNameI = EpAnn NoEpAnns
+type instance XBangTy DocNameI = EpAnn NoEpAnns
+type instance XRecTy DocNameI = EpAnn NoEpAnns
+type instance XExplicitListTy DocNameI = EpAnn NoEpAnns
+type instance XExplicitTupleTy DocNameI = EpAnn NoEpAnns
+type instance XTyLit DocNameI = EpAnn NoEpAnns
+type instance XWildCardTy DocNameI = EpAnn NoEpAnns
type instance XXType DocNameI = HsCoreTy
type instance XNumTy DocNameI = NoExtField