summaryrefslogtreecommitdiff
path: root/compiler/GHC/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Parser')
-rw-r--r--compiler/GHC/Parser/Annotation.hs36
-rw-r--r--compiler/GHC/Parser/Lexer.x7
-rw-r--r--compiler/GHC/Parser/PostProcess.hs98
3 files changed, 91 insertions, 50 deletions
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 1692d394b5..9555291530 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -100,7 +100,7 @@ import qualified GHC.Data.Strict as Strict
{-
Note [exact print annotations]
-~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Given a parse tree of a Haskell module, how can we reconstruct
the original Haskell source code, retaining all whitespace and
source code comments? We need to track the locations of all
@@ -394,7 +394,7 @@ instance Outputable EpaComment where
-- The usual way an 'AddEpAnn' is created is using the 'mj' ("make
-- jump") function, and then it can be inserted into the appropriate
-- annotation.
-data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq,Ord)
+data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
-- | The anchor for an @'AnnKeywordId'@. The Parser inserts the
-- @'EpaSpan'@ variant, giving the exact location of the original item
@@ -460,6 +460,9 @@ instance Outputable EpaLocation where
instance Outputable AddEpAnn where
ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss
+instance Ord AddEpAnn where
+ compare (AddEpAnn kw1 loc1) (AddEpAnn kw2 loc2) = compare (loc1, kw1) (loc2,kw2)
+
-- ---------------------------------------------------------------------
-- | The exact print annotations (EPAs) are kept in the HsSyn AST for
@@ -802,7 +805,8 @@ addTrailingAnnToL s t cs EpAnnNotUsed
addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n)
, comments = comments n <> cs }
where
- addTrailing n = n { al_trailing = t : al_trailing n }
+ -- See Note [list append in addTrailing*]
+ addTrailing n = n { al_trailing = al_trailing n ++ [t]}
-- | Helper function used in the parser to add a 'TrailingAnn' items
-- to an existing annotation.
@@ -813,7 +817,8 @@ addTrailingAnnToA s t cs EpAnnNotUsed
addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n)
, comments = comments n <> cs }
where
- addTrailing n = n { lann_trailing = t : lann_trailing n }
+ -- See Note [list append in addTrailing*]
+ addTrailing n = n { lann_trailing = lann_trailing n ++ [t] }
-- | Helper function used in the parser to add a comma location to an
-- existing annotation.
@@ -822,8 +827,29 @@ addTrailingCommaToN s EpAnnNotUsed l
= EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments
addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l }
where
+ -- See Note [list append in addTrailing*]
addTrailing :: NameAnn -> EpaLocation -> NameAnn
- addTrailing n l = n { nann_trailing = AddCommaAnn l : nann_trailing n }
+ addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn l]}
+
+{-
+Note [list append in addTrailing*]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN
+functions are used to add a separator for an item when it occurs in a
+list. So they are used to capture a comma, vbar, semicolon and similar.
+
+In general, a given element will have zero or one of these. In
+extreme (test) cases, there may be multiple semicolons.
+
+In exact printing we sometimes convert the EpaLocation variant for an
+trailing annotation to the EpaDelta variant, which cannot be sorted.
+
+Hence it is critical that these annotations are captured in the order
+they appear in the original source file.
+
+And so we use the less efficient list append to preserve the order,
+knowing that in most cases the original list is empty.
+-}
-- ---------------------------------------------------------------------
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 10568814d7..d74d17be8f 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -3490,12 +3490,11 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
-}
--- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
+-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate
-- 'AddEpAnn' values for the opening and closing bordering on the start
-- and end of the span
-mkParensEpAnn :: SrcSpan -> [AddEpAnn]
-mkParensEpAnn (UnhelpfulSpan _) = []
-mkParensEpAnn (RealSrcSpan ss _) = [AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc)]
+mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)
+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc))
where
f = srcSpanFile ss
sl = srcSpanStartLine ss
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index ae19e7b7b3..b5511334ec 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -852,26 +852,36 @@ checkTyVars pp_what equals_or_where tc tparms
where
check (HsTypeArg _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc))
- check (HsValArg ty) = chkParens [] emptyComments ty
+ check (HsValArg ty) = chkParens [] [] emptyComments ty
check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $
(PsErrMalformedDecl pp_what (unLoc tc))
-- Keep around an action for adjusting the annotations of extra parens
- chkParens :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs
+ chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs
-> P (LHsTyVarBndr () GhcPs)
- chkParens acc cs (L l (HsParTy an ty))
- = chkParens (mkParensEpAnn (locA l) ++ acc) (cs Semi.<> epAnnComments an) ty
- chkParens acc cs ty = chk acc cs ty
+ chkParens ops cps cs (L l (HsParTy an ty))
+ = let
+ (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
+ in
+ chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) ty
+ chkParens ops cps cs ty = chk ops cps cs ty
-- Check that the name space is correct!
- chk :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
- chk an cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))
+ chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)
+ chk ops cps cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))
| isRdrTyVar tv
- = return (L (widenLocatedAn (l Semi.<> annt) an)
- (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k))
- chk an cs (L l (HsTyVar ann _ (L ltv tv)))
- | isRdrTyVar tv = return (L (widenLocatedAn l an)
+ = let
+ an = (reverse ops) ++ cps
+ in
+ return (L (widenLocatedAn (l Semi.<> annt) an)
+ (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k))
+ chk ops cps cs (L l (HsTyVar ann _ (L ltv tv)))
+ | isRdrTyVar tv
+ = let
+ an = (reverse ops) ++ cps
+ in
+ return (L (widenLocatedAn l an)
(UserTyVar (addAnns ann an cs) () (L ltv tv)))
- chk _ _ t@(L loc _)
+ chk _ _ _ t@(L loc _)
= addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)
@@ -951,34 +961,36 @@ checkTyClHdr :: Bool -- True <=> class header
-- Int :*: Bool into (:*:, [Int, Bool])
-- returning the pieces
checkTyClHdr is_cls ty
- = goL ty [] [] Prefix
+ = goL ty [] [] [] Prefix
where
- goL (L l ty) acc ann fix = go (locA l) ty acc ann fix
+ goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix
-- workaround to define '*' despite StarIsType
- go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ann' fix
+ go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
= do { addPsMessage (locA l) PsWarnStarBinder
; let name = mkOccName tcClsName (starSym isUni)
; let a' = newAnns l an
; return (L a' (Unqual name), acc, fix
- , ann') }
-
- go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix
- | isRdrTc tc = return (ltc, acc, fix, ann)
- go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix
- | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)
- go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensEpAnn l) fix
- go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix
- go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix
- go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
+ , (reverse ops') ++ cps') }
+
+ go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
+ | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps)
+ go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ops cps _fix
+ | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)
+ go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
+ where
+ (o,c) = mkParensEpAnn (realSrcSpan l)
+ go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix
+ go _ (HsAppKindTy l ty ki) acc ops cps fix = goL ty (HsTypeArg l ki:acc) ops cps fix
+ go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
= return (L (noAnnSrcSpan l) (nameRdrName tup_name)
- , map HsValArg ts, fix, ann)
+ , map HsValArg ts, fix, (reverse ops)++cps)
where
arity = length ts
tup_name | is_cls = cTupleTyConName arity
| otherwise = getName (tupleTyCon Boxed arity)
-- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?)
- go l _ _ _ _
+ go l _ _ _ _ _
= addFatalError $ mkPlainErrorMsgEnvelope l $
(PsErrMalformedTyOrClDecl ty)
@@ -1054,7 +1066,8 @@ checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) =
EpAnnNotUsed -> ([],[],emptyComments)
EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs)
return (L (SrcSpanAnn (EpAnn (spanAsAnchor l)
- (AnnContext Nothing (op Semi.<> oparens) (cp Semi.<> cparens)) (cs Semi.<> cs')) l) ts)
+ -- Append parens so that the original order in the source is maintained
+ (AnnContext Nothing (oparens ++ op) (cp ++ cparens)) (cs Semi.<> cs')) l) ts)
check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty))
-- to be sure HsParTy doesn't get into the way
@@ -1311,26 +1324,29 @@ isFunLhs :: LocatedA (PatBuilder GhcPs)
[LocatedA (PatBuilder GhcPs)],[AddEpAnn]))
-- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS
-isFunLhs e = go e [] []
+isFunLhs e = go e [] [] []
where
- go (L _ (PatBuilderVar (L loc f))) es ann
- | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann))
- go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann
- go (L l (PatBuilderPar _ e _)) es@(_:_) ann
- = go e es (ann ++ mkParensEpAnn (locA l))
- go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ann
+ go (L _ (PatBuilderVar (L loc f))) es ops cps
+ | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))
+ go (L _ (PatBuilderApp f e)) es ops cps = go f (e:es) ops cps
+ go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps
+ = let
+ (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
+ in
+ go e es (o:ops) (c:cps)
+ go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps
| not (isRdrDataCon op) -- We have found the function!
- = return (Just (L loc' op, Infix, (l:r:es), (anns ++ ann)))
+ = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps)))
| otherwise -- Infix data con; keep going
- = do { mb_l <- go l es ann
+ = do { mb_l <- go l es ops cps
; case mb_l of
- Just (op', Infix, j : k : es', ann')
- -> return (Just (op', Infix, j : op_app : es', ann'))
+ Just (op', Infix, j : k : es', anns')
+ -> return (Just (op', Infix, j : op_app : es', anns'))
where
op_app = L loc (PatBuilderOpApp k
- (L loc' op) r (EpAnn loca anns cs))
+ (L loc' op) r (EpAnn loca (reverse ops++cps) cs))
_ -> return Nothing }
- go _ _ _ = return Nothing
+ go _ _ _ _ = return Nothing
mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
mkBangTy anns strictness =
View Lorry Controller Status