diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index bf8ff87d0c7ae23eea744ac331a284f9dc227d4c..72b3cb811100ae10068547d3b5294181e8435ea1 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -72,8 +72,8 @@ Global bindings (where clauses) -- the ...LR datatypes are parameterized by two id types, -- one for the left and one for the right. -type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList -type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where")) +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where")) type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index d510e76695b68678010891e3efc17c8e147dab17..8c21c3f94a9bad3a682cc3c43dbe3567602f43bc 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -67,6 +67,9 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` annotationModule `extQ` annotationGrhsAnn `extQ` annotationAnnList + `extQ` annotationAnnListWhere + `extQ` annotationAnnListCommas + `extQ` annotationAnnListIE `extQ` annotationEpAnnImportDecl `extQ` annotationNoEpAnns `extQ` annotationExprBracket @@ -371,8 +374,17 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") - annotationAnnList :: EpAnn AnnList -> SDoc - annotationAnnList = annotation' (text "EpAnn AnnList") + annotationAnnList :: EpAnn (AnnList ()) -> SDoc + annotationAnnList = annotation' (text "EpAnn (AnnList ())") + + annotationAnnListWhere :: EpAnn (AnnList (EpToken "where")) -> SDoc + annotationAnnListWhere = annotation' (text "EpAnn (AnnList (EpToken \"where\"))") + + annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc + annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") + + annotationAnnListIE :: EpAnn (AnnList (EpToken "hiding", [EpToken ","])) -> SDoc + annotationAnnListIE = annotation' (text "EpAnn (AnnList (EpToken \"hiding\", [EpToken \",\"]))") annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") @@ -392,7 +404,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnA :: EpAnn AnnListItem -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnL :: EpAnn AnnList -> SDoc + srcSpanAnnL :: EpAnn (AnnList ()) -> SDoc srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") srcSpanAnnP :: EpAnn AnnPragma -> SDoc diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 9e7351d97ac695e0994374e0a645c636b18d02d9..b2cfd2706af65d9ac75ff92c886f9359a3d07ef4 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -314,11 +314,11 @@ type instance XLet GhcPs = (EpToken "let", EpToken "in") type instance XLet GhcRn = NoExtField type instance XLet GhcTc = NoExtField -type instance XDo GhcPs = AnnList +type instance XDo GhcPs = AnnList EpaLocation type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = AnnList +type instance XExplicitList GhcPs = AnnList () type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type -- GhcPs: ExplicitList includes all source-level @@ -415,7 +415,7 @@ type instance XPragE (GhcPass _) = NoExtField type instance XFunRhs = AnnFunRhs -type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL +type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA arrowToHsExpr :: HsArrowOf (LocatedA (HsExpr GhcRn)) GhcRn -> LocatedA (HsExpr GhcRn) @@ -1323,7 +1323,7 @@ type instance XCmdArrApp GhcPs = AddEpAnn type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type -type instance XCmdArrForm GhcPs = AnnList +type instance XCmdArrForm GhcPs = AnnList () -- | fixity (filled in by the renamer), for forms that were converted from -- OpApp's by the renamer type instance XCmdArrForm GhcRn = Maybe Fixity @@ -1350,7 +1350,7 @@ type instance XCmdLet GhcPs = (EpToken "let", EpToken "in") type instance XCmdLet GhcRn = NoExtField type instance XCmdLet GhcTc = NoExtField -type instance XCmdDo GhcPs = AnnList +type instance XCmdDo GhcPs = AnnList EpaLocation type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type @@ -1765,7 +1765,7 @@ type instance XTransStmt (GhcPass _) GhcPs b = AnnTransStmt type instance XTransStmt (GhcPass _) GhcRn b = NoExtField type instance XTransStmt (GhcPass _) GhcTc b = Type -type instance XRecStmt (GhcPass _) GhcPs b = AnnList +type instance XRecStmt (GhcPass _) GhcPs b = AnnList (EpToken "rec") type instance XRecStmt (GhcPass _) GhcRn b = NoExtField type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc @@ -2473,16 +2473,14 @@ instance UnXRec p => Outputable (DotFieldOcc p) where type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnC -type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))))] = SrcSpanAnnL -type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))))] = SrcSpanAnnL +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] - = SrcSpanAnnL type instance Anno (HsCmdTop (GhcPass p)) = EpAnnCO -type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL -type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnL +type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnLW +type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnLW type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA type instance Anno [LocatedA (Pat (GhcPass p))] = EpaLocation @@ -2492,7 +2490,7 @@ type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnL +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO type instance Anno FieldLabelString = SrcSpanAnnN diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 4d7b2c69107d3e7f2ab7c903eeccc1a5b8beb3c3..ef82214d6a9e91018a304b61f60ce3c74e25056f 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -96,7 +96,7 @@ data XImportDeclPass = XImportDeclPass type instance XXImportDecl (GhcPass _) = DataConCantHappen type instance Anno ModuleName = SrcSpanAnnA -type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL +type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnLI deriving instance Data (IEWrappedName GhcPs) deriving instance Data (IEWrappedName GhcRn) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index fa858271f637fca7479103ec03c8d09c3342cb1a..587793828eb3ad51da5d178ad60a92fb2610309a 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -111,7 +111,7 @@ type instance XBangPat GhcPs = EpToken "!" type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = AnnList +type instance XListPat GhcPs = AnnList () -- After parsing, ListPat can refer to a built-in Haskell list pattern -- or an overloaded list pattern. type instance XListPat GhcRn = NoExtField diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index d19c73181d2e67afe4d679fc46df48b09d55db97..7a467d675a4815cd3d74a9b3b9f04b752b1dfbdb 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -478,7 +478,7 @@ type instance XSpliceTy GhcTc = Kind type instance XDocTy (GhcPass _) = NoExtField type instance XBangTy (GhcPass _) = ((EpaLocation, EpaLocation, EpaLocation), SourceText) -type instance XRecTy GhcPs = AnnList +type instance XRecTy GhcPs = AnnList () type instance XRecTy GhcRn = NoExtField type instance XRecTy GhcTc = NoExtField diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index d19b7dee549bf3dca06904d37c03dce4ec52c0b6..40bc935195c8f8061fc98696bf7994ff98047c71 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -212,13 +212,13 @@ unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)] type AnnoBody p body = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin - , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL + , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnLW , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA ) mkMatchGroup :: AnnoBody p body => Origin - -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkMatchGroup origin matches = MG { mg_ext = origin , mg_alts = matches } @@ -226,7 +226,7 @@ mkMatchGroup origin matches = MG { mg_ext = origin mkLamCaseMatchGroup :: AnnoBody p body => Origin -> HsLamVariant - -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkLamCaseMatchGroup origin lam_variant (L l matches) = mkMatchGroup origin (L l $ map fixCtxt matches) @@ -330,12 +330,12 @@ nlParPat p = noLocA (gParPat p) mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs -mkHsDo :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsDoAnns :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> AnnList -> HsExpr GhcPs +mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> AnnList + -> AnnList EpaLocation -> HsExpr GhcPs mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-" @@ -359,12 +359,12 @@ mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc) emptyRecStmt :: (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] - ~ SrcSpanAnnL) + ~ SrcSpanAnnLW) => StmtLR (GhcPass idL) GhcPs bodyR emptyRecStmtName :: (Anno [GenLocated (Anno (StmtLR GhcRn GhcRn bodyR)) (StmtLR GhcRn GhcRn bodyR)] - ~ SrcSpanAnnL) + ~ SrcSpanAnnLW) => StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) @@ -372,9 +372,9 @@ mkRecStmt :: forall (idL :: Pass) bodyR. (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] - ~ SrcSpanAnnL) - => AnnList - -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] + ~ SrcSpanAnnLW) + => AnnList (EpToken "rec") + -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) { recS_stmts = stmts } diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index e68ac7d9b4d11bbb282dd7b6842c78c3f09886b0..8b88fa7914faff59d7b13fbc278f6c647d4bce40 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -855,7 +855,7 @@ type AnnoBody p body = ( Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] - ~ SrcSpanAnnL + ~ SrcSpanAnnLW , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index c6724002c9ad551ac8187ca24569c873b1ff7cb6..b5e1336384654d558b16e0d78cdf2754f50fb203 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1002,12 +1002,12 @@ header_top_importdecls :: { [LImportDecl GhcPs] } ----------------------------------------------------------------------------- -- The Export List -maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) } +maybeexports :: { (Maybe (LocatedLI [LIE GhcPs])) } : '(' exportlist ')' {% fmap Just $ amsr (sLL $1 $> (fromOL $ snd $2)) - (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) } + (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) [] (noAnn,fst $2) []) } | {- empty -} { Nothing } -exportlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) } +exportlist :: { ([EpToken ","], OrdList (LIE GhcPs)) } : exportlist1 { ([], $1) } | {- empty -} { ([], nilOL) } @@ -1016,7 +1016,7 @@ exportlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) } SnocOL hs t -> do t' <- addTrailingCommaA t (gl $2) return ([], snocOL hs t')} - | ',' { ([mj AnnComma $1], nilOL) } + | ',' { ([epTok $1], nilOL) } exportlist1 :: { OrdList (LIE GhcPs) } : exportlist1 ',' export_cs @@ -1173,22 +1173,22 @@ maybeas :: { (Maybe EpaLocation,Located (Maybe (LocatedA ModuleName))) } ,sLL $1 $> (Just $2)) } | {- empty -} { (Nothing,noLoc Nothing) } -maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs])) } +maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> return (L (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } -impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) } +impspec :: { Located (ImportListInterpretation, LocatedLI [LIE GhcPs]) } : '(' importlist ')' {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $2) - (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) + (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) [] (noAnn,fst $2) []) ; return $ sLL $1 $> (Exactly, es)} } | 'hiding' '(' importlist ')' {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $3) - (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) []) + (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) [] (epTok $1,fst $3) []) ; return $ sLL $1 $> (EverythingBut, es)} } -importlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) } +importlist :: { ([EpToken ","], OrdList (LIE GhcPs)) } : importlist1 { ([], $1) } | {- empty -} { ([], nilOL) } @@ -1197,7 +1197,7 @@ importlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) } SnocOL hs t -> do t' <- addTrailingCommaA t (gl $2) return ([], snocOL hs t')} - | ',' { ([mj AnnComma $1], nilOL) } + | ',' { ([epTok $1], nilOL) } importlist1 :: { OrdList (LIE GhcPs) } : importlist1 ',' import @@ -1738,11 +1738,11 @@ cvars1 :: { [RecordPatSynField GhcPs] } | var ',' cvars1 {% do { h <- addTrailingCommaN $1 (gl $2) ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}} -where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) } - : 'where' '{' decls '}' {% amsr (sLL $1 $> (snd $ unLoc $3)) - (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) (mj AnnWhere $1: (fst $ unLoc $3)) []) } - | 'where' vocurly decls close {% amsr (sLL $1 $3 (snd $ unLoc $3)) - (AnnList (Just $ glR $3) Nothing Nothing (mj AnnWhere $1: (fst $ unLoc $3)) []) } +where_decls :: { LocatedLW (OrdList (LHsDecl GhcPs)) } + : 'where' '{' decls '}' {% amsr (sLL $1 $> (thdOf3 $ unLoc $3)) + (AnnList (Just (fstOf3 $ unLoc $3)) (Just $ moc $2) (Just $ mcc $4) (sndOf3 $ unLoc $3) (epTok $1) []) } + | 'where' vocurly decls close {% amsr (sLL $1 $3 (thdOf3 $ unLoc $3)) + (AnnList (Just (fstOf3 $ unLoc $3)) Nothing Nothing (sndOf3 $ unLoc $3) (epTok $1) []) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -1855,56 +1855,56 @@ where_inst :: { Located ((EpToken "where", (EpToken "{", EpToken "}", [EpToken " -- Declarations in binding groups other than classes and instances -- -decls :: { Located ([AddEpAnn], OrdList (LHsDecl GhcPs)) } - : decls ';' decl {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> ((fst $ unLoc $1) ++ (msemiA $2) +decls :: { Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs)) } + : decls ';' decl {% if isNilOL (thdOf3 $ unLoc $1) + then return (sLL $1 $> (glEE $2 $3, (sndOf3 $ unLoc $1) ++ (msemiA $2) , unitOL $3)) - else case (snd $ unLoc $1) of + else case (thdOf3 $ unLoc $1) of SnocOL hs t -> do t' <- addTrailingSemiA t (gl $2) let { this = unitOL $3; rest = snocOL hs t'; these = rest `appOL` this } return (rest `seq` this `seq` these `seq` - (sLL $1 $> (fst $ unLoc $1, these))) } - | decls ';' {% if isNilOL (snd $ unLoc $1) - then return (sLZ $1 $> (((fst $ unLoc $1) ++ (msemiA $2) - ,snd $ unLoc $1))) - else case (snd $ unLoc $1) of + (sLL $1 $> (glEE $1 $3, sndOf3 $ unLoc $1, these))) } + | decls ';' {% if isNilOL (thdOf3 $ unLoc $1) + then return (sLZ $1 $> (glR $2, (sndOf3 $ unLoc $1) ++ (msemiA $2) + ,thdOf3 $ unLoc $1)) + else case (thdOf3 $ unLoc $1) of SnocOL hs t -> do t' <- addTrailingSemiA t (gl $2) - return (sLZ $1 $> (fst $ unLoc $1 - , snocOL hs t')) } - | decl { sL1 $1 ([], unitOL $1) } - | {- empty -} { noLoc ([],nilOL) } + return (sLZ $1 $> (glEEz $1 $2, sndOf3 $ unLoc $1, snocOL hs t')) } + | decl { sL1 $1 (glR $1, [], unitOL $1) } + | {- empty -} { noLoc (noAnn, [],nilOL) } -decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } - : '{' decls '}' { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) [] - ,sL1 $2 $ snd $ unLoc $2) } - | vocurly decls close { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) [] - ,sL1 $2 $ snd $ unLoc $2) } +decllist :: { Located (AnnList (),Located (OrdList (LHsDecl GhcPs))) } + : '{' decls '}' { sLL $1 $> (AnnList (Just (fstOf3 $ unLoc $2)) (Just $ moc $1) (Just $ mcc $3) (sndOf3 $ unLoc $2) noAnn [] + ,sL1 $2 $ thdOf3 $ unLoc $2) } + | vocurly decls close { L (getHasLoc $ fstOf3 $ unLoc $2) (AnnList (Just (glR $2)) Nothing Nothing (sndOf3 $ unLoc $2) noAnn [] + ,sL1 $2 $ thdOf3 $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- binds :: { Located (HsLocalBinds GhcPs) } -- May have implicit parameters -- No type declarations - : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) + : decllist {% do { let { (AnnList anc o c s _ t, decls) = unLoc $1 } + ; val_binds <- cvBindGroup (unLoc $ decls) ; !cs <- getCommentsFor (gl $1) - ; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} } + ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList anc o c s noAnn t) cs) val_binds)} } | '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] noAnn []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) } | vocurly dbinds close {% acs (gl $2) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] noAnn []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) } wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) } -- May have implicit parameters -- No type declarations : 'where' binds {% do { r <- acs (comb2 $1 $>) (\loc cs -> - (L loc (annBinds (mj AnnWhere $1) cs (unLoc $2)))) + (L loc (annBinds (epTok $1) cs (unLoc $2)))) ; return $ Just r} } | {- empty -} { Nothing } @@ -2329,7 +2329,7 @@ atype :: { LHsType GhcPs } | PREFIX_TILDE atype {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcLazy $2)) } | PREFIX_BANG atype {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcStrict $2)) } - | '{' fielddecls '}' {% do { decls <- amsA' (sLL $1 $> $ HsRecTy (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) $2) + | '{' fielddecls '}' {% do { decls <- amsA' (sLL $1 $> $ HsRecTy (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] noAnn []) $2) ; checkRecordSyntax decls }} -- Constructor sigs only @@ -3024,7 +3024,7 @@ aexp :: { ECP } | '\\' argpats '->' exp { ECP $ unECP $4 >>= \ $4 -> mkHsLamPV (comb2 $1 $>) LamSingle - (sLLl $1 $> + (sLLld $1 $> [sLLa $1 $> $ Match { m_ext = noExtField , m_ctxt = LamAlt LamSingle @@ -3068,14 +3068,15 @@ aexp :: { ECP } mkHsDoPV (comb2 $1 $2) (fmap mkModuleNameFS (getDO $1)) $2 - (AnnList (Just $ glR $2) Nothing Nothing [mj AnnDo $1] []) } + (glR $1) + (glR $2) } | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 -> fmap ecpFromExp $ amsA' (L (comb2 $1 $2) - (mkHsDoAnns (MDoExpr $ - fmap mkModuleNameFS (getMDO $1)) - $2 - (AnnList (Just $ glR $2) Nothing Nothing [mj AnnMdo $1] []) )) } + (mkMDo (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) + $2 + (glR $1) + (glR $2))) } | 'proc' aexp '->' exp {% (checkPattern <=< runPV) (unECP $2) >>= \ p -> runPV (unECP $4) >>= \ $4@cmd -> @@ -3184,7 +3185,7 @@ aexp2 :: { ECP } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromCmd $ - amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) $2 Prefix + amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] noAnn []) $2 Prefix (reverse $3)) } projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) } @@ -3318,9 +3319,9 @@ tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] } -- Never empty. list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b) } : texp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> - mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] []) } + mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] noAnn []) } | lexps { \loc (ao,ac) -> $1 >>= \ $1 -> - mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) } + mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] noAnn []) } | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok (addEpAnnLoc ao)) Nothing (epTok $2) (EpTok (addEpAnnLoc ac))) Nothing (From $1)) >>= ecpFromExp' } @@ -3344,7 +3345,7 @@ list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (Locate { \loc (ao,ac) -> checkMonadComp >>= \ ctxt -> unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2) - ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (Just ao) (Just ac) [] [])) + ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (Just ao) (Just ac) [] noAnn [])) >>= ecpFromExp' } } lexps :: { forall b. DisambECP b => PV [LocatedA b] } @@ -3447,35 +3448,35 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } ----------------------------------------------------------------------------- -- Case alternatives -altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) } +altslist(PATS) :: { forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)]) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsr (sLL $1 $> (reverse (snd $ unLoc $2))) - (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) } + (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) noAnn []) } | vocurly alts(PATS) close { $2 >>= \ $2 -> amsr (L (getLoc $2) (reverse (snd $ unLoc $2))) - (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) } - | '{' '}' { amsr (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) } + (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) noAnn []) } + | '{' '}' { amsr (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] noAnn []) } | vocurly close { return $ noLocA [] } -alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) } +alts(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) } : alts1(PATS) { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts(PATS) { $2 >>= \ $2 -> return $ - sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2) ) + sLL $1 $> (((mzEpTok $1) : (fst $ unLoc $2) ) ,snd $ unLoc $2) } -alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) } +alts1(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) } : alts1(PATS) ';' alt(PATS) { $1 >>= \ $1 -> $3 >>= \ $3 -> case snd $ unLoc $1 of - [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2) + [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2] ,[$3])) (h:t) -> do h' <- addTrailingSemiA h (gl $2) return (sLL $1 $> (fst $ unLoc $1,$3 : h' : t)) } | alts1(PATS) ';' { $1 >>= \ $1 -> case snd $ unLoc $1 of - [] -> return (sLZ $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2) + [] -> return (sLZ $1 $> ((fst $ unLoc $1) ++ [mzEpTok $2] ,[])) (h:t) -> do h' <- addTrailingSemiA h (gl $2) @@ -3562,11 +3563,11 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) } +stmtlist :: { forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))]) } : '{' stmts '}' { $2 >>= \ $2 -> - amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) } + amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) noAnn []) } | vocurly stmts close { $2 >>= \ $2 -> amsr - (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) } + (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) noAnn []) } -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -3574,19 +3575,19 @@ stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (Locat -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)])) } +stmts :: { forall b. DisambECP b => PV (Located (OrdList (EpToken ";"),[LStmt GhcPs (LocatedA b)])) } : stmts ';' stmt { $1 >>= \ $1 -> $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) -> case (snd $ unLoc $1) of - [] -> return (sLL $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2) - ,$3 : (snd $ unLoc $1))) + [] -> return (sLL $1 $> ( (fst $ unLoc $1) `snocOL` (epTok $2) + , $3 : (snd $ unLoc $1))) (h:t) -> do { h' <- addTrailingSemiA h (gl $2) ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(h':t)) }} | stmts ';' { $1 >>= \ $1 -> case (snd $ unLoc $1) of - [] -> return (sLZ $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2),snd $ unLoc $1)) + [] -> return (sLZ $1 $> ((fst $ unLoc $1) `snocOL` (epTok $2),snd $ unLoc $1)) (h:t) -> do { h' <- addTrailingSemiA h (gl $2) ; return $ sLZ $1 $> (fst $ unLoc $1,h':t) }} @@ -3608,7 +3609,7 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> - amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn $1 $2 AnnRec) $2) } + amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) $2) $2) } qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : bindpat '<-' exp { unECP $3 >>= \ $3 -> @@ -3738,7 +3739,7 @@ name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] } name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) } : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens $2)) - (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) } + (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] noAnn []) } | name_var { sL1a $1 (Var $1) } namelist :: { Located [LocatedN RdrName] } @@ -4343,6 +4344,10 @@ sLLa !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) sLLl :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedL c sLLl !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) +{-# INLINE sLLld #-} +sLLld :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedLW c +sLLld !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) + {-# INLINE sLLAsl #-} sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c sLLAsl [] = sL1 @@ -4483,16 +4488,11 @@ mj !a !l = AddEpAnn a (srcSpan2e $ gl l) mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn mjN !a !l = AddEpAnn a (srcSpan2e $ glA l) --- |Construct an AddEpAnn from the annotation keyword and the location --- of the keyword itself, provided the span is not zero width -mz :: AnnKeywordId -> Located e -> [AddEpAnn] -mz !a !l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)] - msemi :: Located e -> [TrailingAnn] msemi !l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)] -msemiA :: Located e -> [AddEpAnn] -msemiA !l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn AnnSemi (srcSpan2e $ gl l)] +msemiA :: Located e -> [EpToken ";"] +msemiA !l = if isZeroWidthSpan (gl l) then [] else [EpTok (srcSpan2e $ gl l)] msemim :: Located e -> Maybe EpaLocation msemim !l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l) @@ -4525,6 +4525,11 @@ glR !la = EpaSpan (getHasLoc la) glEE :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation glEE !x !y = spanAsAnchor $ comb2 x y +glEEz :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation +glEEz !x !y = if isZeroWidthSpan (getHasLoc y) + then spanAsAnchor (getHasLoc x) + else spanAsAnchor $ comb2 x y + glRM :: Located a -> Maybe EpaLocation glRM (L !l _) = Just $ spanAsAnchor l @@ -4638,9 +4643,9 @@ commentsPA la@(L l a) = do !cs <- getPriorCommentsFor (getLocA la) return (L (addCommentsToEpAnn l cs) a) -hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList -hsDoAnn (L l _) (L ll _) kw - = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] [] +hsDoAnn :: EpToken "rec" -> LocatedAn t b -> AnnList (EpToken "rec") +hsDoAnn tok (L ll _) + = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [] tok [] listAsAnchor :: [LocatedAn t a] -> Located b -> EpaLocation listAsAnchor [] (L l _) = spanAsAnchor l diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index d0439e0baba6f08e571088c20ffe533a9c044695..05c8ed25c8ceec9d8bd79870646bb30cd7530557 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -39,7 +39,9 @@ module GHC.Parser.Annotation ( -- ** Annotations in 'GenLocated' LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP, + LocatedLC, LocatedLS, LocatedLW, LocatedLI, SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, + SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, SrcSpanAnnLI, LocatedE, -- ** Annotation data types used in 'GenLocated' @@ -67,7 +69,7 @@ module GHC.Parser.Annotation ( -- ** Building up annotations reAnnL, reAnnC, - addAnns, addAnnsA, widenSpan, widenSpanL, widenAnchor, widenAnchorS, + addAnns, addAnnsA, widenSpan, widenSpanL, widenSpanT, widenAnchor, widenAnchorT, widenAnchorS, widenLocatedAn, widenLocatedAnL, listLocation, @@ -603,13 +605,21 @@ type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN type LocatedL = GenLocated SrcSpanAnnL +type LocatedLC = GenLocated SrcSpanAnnLC +type LocatedLS = GenLocated SrcSpanAnnLS +type LocatedLW = GenLocated SrcSpanAnnLW +type LocatedLI = GenLocated SrcSpanAnnLI type LocatedP = GenLocated SrcSpanAnnP type LocatedC = GenLocated SrcSpanAnnC type SrcSpanAnnA = EpAnn AnnListItem type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnL = EpAnn AnnList +type SrcSpanAnnL = EpAnn (AnnList ()) +type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","]) +type SrcSpanAnnLS = EpAnn (AnnList ()) +type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where")) +type SrcSpanAnnLI = EpAnn (AnnList (EpToken "hiding", [EpToken ","])) type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnC = EpAnn AnnContext @@ -687,15 +697,16 @@ data AnnListItem -- | Annotation for the "container" of a list. This captures -- surrounding items such as braces if present, and introductory -- keywords such as 'where'. -data AnnList +data AnnList a = AnnList { - al_anchor :: Maybe EpaLocation, -- ^ start point of a list having layout - al_open :: Maybe AddEpAnn, - al_close :: Maybe AddEpAnn, - al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword - al_trailing :: [TrailingAnn] -- ^ items appearing after the - -- list, such as '=>' for a - -- context + al_anchor :: !(Maybe EpaLocation), -- ^ start point of a list having layout + al_open :: !(Maybe AddEpAnn), + al_close :: !(Maybe AddEpAnn), + al_semis :: [EpToken ";"], -- decls + al_rest :: !a, + al_trailing :: ![TrailingAnn] -- ^ items appearing after the + -- list, such as '=>' for a + -- context } deriving (Data,Eq) -- --------------------------------------------------------------------- @@ -950,7 +961,7 @@ trailingAnnToAddEpAnn (AddDarrowAnn ss) = AddEpAnn AnnDarrow ss -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation. addTrailingAnnToL :: TrailingAnn -> EpAnnComments - -> EpAnn AnnList -> EpAnn AnnList + -> EpAnn (AnnList a) -> EpAnn (AnnList a) addTrailingAnnToL t cs n = n { anns = addTrailing (anns n) , comments = comments n <> cs } where @@ -1132,6 +1143,10 @@ widenSpanL s as = foldl combineSrcSpans s (go as) go ((EpaSpan _):rest) = go rest go ((EpaDelta _ _ _):rest) = go rest +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 @@ -1178,6 +1193,10 @@ 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 + widenAnchorS :: EpaLocation -> SrcSpan -> EpaLocation widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr) = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr)) @@ -1388,6 +1407,9 @@ instance (NoAnn a, NoAnn b, NoAnn c, NoAnn d) => NoAnn (a, b, c, d) where instance NoAnn Bool where noAnn = False +instance NoAnn () where + noAnn = () + instance (NoAnn ann) => NoAnn (EpAnn ann) where noAnn = EpAnn noSpanAnchor noAnn emptyComments @@ -1400,8 +1422,8 @@ instance NoAnn AnnListItem where instance NoAnn AnnContext where noAnn = AnnContext Nothing [] [] -instance NoAnn AnnList where - noAnn = AnnList Nothing Nothing Nothing [] [] +instance NoAnn a => NoAnn (AnnList a) where + noAnn = AnnList Nothing Nothing Nothing noAnn noAnn [] instance NoAnn NameAnn where noAnn = NameAnnTrailing [] @@ -1496,9 +1518,9 @@ instance Outputable NameAnn where ppr (NameAnnTrailing t) = text "NameAnnTrailing" <+> ppr t -instance Outputable AnnList where - ppr (AnnList a o c r t) - = text "AnnList" <+> ppr a <+> ppr o <+> ppr c <+> ppr r <+> ppr t +instance (Outputable a) => Outputable (AnnList a) where + ppr (AnnList anc o c s a t) + = text "AnnList" <+> ppr anc <+> ppr o <+> ppr c <+> ppr s <+> ppr a <+> ppr t instance Outputable AnnPragma where ppr (AnnPragma o c s l ca t m) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 048cf881a2e2d0bf3acf3a241ba2ad3e7f8375d1..854e113d32eb9685004f5564a33251229f69bec9 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -16,7 +16,7 @@ module GHC.Parser.PostProcess ( mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkSpliceDecl, + mkHsDo, mkMDo, mkSpliceDecl, mkRoleAnnotDecl, mkClassDecl, mkTyData, mkDataFamInst, @@ -33,7 +33,6 @@ module GHC.Parser.PostProcess ( setRdrNameSpace, fromSpecTyVarBndr, fromSpecTyVarBndrs, annBinds, - fixValbindsAnn, stmtsAnchor, stmtsLoc, cvBindGroup, @@ -431,6 +430,10 @@ mkRoleAnnotDecl loc tycon roles anns addFatalError $ mkPlainErrorMsgEnvelope loc_role $ (PsErrIllegalRoleName role nearby) +mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs +mkMDo ctxt stmts tok loc + = mkHsDoAnns ctxt stmts (AnnList (Just loc) Nothing Nothing [] tok []) + -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if -- any of the provided binders has an 'InferredSpec' annotation. @@ -449,20 +452,22 @@ fromSpecTyVarBndr (L loc (HsTvb xtv flag idp k)) = do return $ L loc (HsTvb xtv () idp k) -- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ -annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs +annBinds :: EpToken "where" -> EpAnnComments -> HsLocalBinds GhcPs -> (HsLocalBinds GhcPs, Maybe EpAnnComments) -annBinds a cs (HsValBinds an bs) = (HsValBinds (add_where a an cs) bs, Nothing) -annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing) +annBinds w cs (HsValBinds an bs) = (HsValBinds (add_where w an cs) bs, Nothing) +annBinds w cs (HsIPBinds an bs) = (HsIPBinds (add_where w an cs) bs, Nothing) annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs) -add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList -add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs _))) (EpAnn a (AnnList anc o c r t) cs) cs2 +add_where :: EpToken "where" -> EpAnn (AnnList (EpToken "where")) -> EpAnnComments -> EpAnn (AnnList (EpToken "where")) +add_where w@(EpTok (EpaSpan (RealSrcSpan rs _))) (EpAnn a al cs) cs2 | valid_anchor a - = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2) + = EpAnn (widenAnchorT a w) (al { al_rest = w}) (cs Semi.<> cs2) | otherwise = EpAnn (patch_anchor rs a) - (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2) -add_where (AddEpAnn _ _) _ _ = panic "add_where" + (al { al_anchor = (fmap (patch_anchor rs) (al_anchor al)) + , al_rest = w}) + (cs Semi.<> cs2) +add_where _ _ _ = panic "add_where" -- EpaDelta should only be used for transformations valid_anchor :: EpaLocation -> Bool @@ -478,21 +483,17 @@ patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb) r = if srcSpanStartLine r0 < 0 then r1 else r0 patch_anchor _ (EpaSpan ss) = EpaSpan ss -fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList -fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs) - = (EpAnn (widenAnchor anchor (r ++ map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs) - -- | The anchor for a stmtlist is based on either the location or -- the first semicolon annotion. -stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe EpaLocation -stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan (RealSrcSpan r rb))) _), _)) +stmtsAnchor :: Located (OrdList (EpToken tok),a) -> Maybe EpaLocation +stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (EpTok (EpaSpan (RealSrcSpan r rb))) _), _)) = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb) stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb) stmtsAnchor _ = Nothing -stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan +stmtsLoc :: Located (OrdList (EpToken tok),a) -> SrcSpan stmtsLoc (L l ((ConsOL aa _), _)) - = widenSpan l [aa] + = widenSpanT l aa stmtsLoc (L l _) = l {- ********************************************************************** @@ -716,7 +717,7 @@ tyConToDataCon (L loc tc) occ = rdrNameOcc tc mkPatSynMatchGroup :: LocatedN RdrName - -> LocatedL (OrdList (LHsDecl GhcPs)) + -> LocatedLW (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = do { matches <- mapM fromDecl (fromOL decls) @@ -1421,7 +1422,7 @@ checkFunBind locF ann_fun (L lf fun) is_infix (L lp pats) (L _ grhss) | Infix <- is_infix = ParseContext (Just fun) NoIncompleteDoBlock | otherwise = noParseContext -makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] +makeFunBind :: LocatedN RdrName -> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms @@ -1627,11 +1628,11 @@ instance DisambInfixOp RdrName where type AnnoBody b = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnCO - , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL + , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnLW , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA , Anno [LocatedA (StmtLR GhcPs GhcPs - (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL + (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW ) -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are @@ -1666,11 +1667,11 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b -> PV (LocatedA b) -- | Disambiguate "case ... of ..." - mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)]) + mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedLW [LMatch GhcPs (LocatedA b)]) -> EpAnnHsCase -> PV (LocatedA b) -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases" mkHsLamPV :: SrcSpan -> HsLamVariant - -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> EpAnnLam + -> (LocatedLW [LMatch GhcPs (LocatedA b)]) -> EpAnnLam -> PV (LocatedA b) -- | Function argument representation type FunArg b @@ -1694,8 +1695,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where mkHsDoPV :: SrcSpan -> Maybe ModuleName -> - LocatedL [LStmt GhcPs (LocatedA b)] -> - AnnList -> + LocatedLW [LStmt GhcPs (LocatedA b)] -> + EpaLocation -> -- Token + EpaLocation -> -- Anchor PV (LocatedA b) -- | Disambiguate "( ... )" (parentheses) mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b) @@ -1711,7 +1713,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where mkHsTySigPV :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> EpUniToken "::" "∷" -> PV (LocatedA b) -- | Disambiguate "[a,b,c]" (list syntax) - mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) + mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList () -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) @@ -1822,7 +1824,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsOpAppPV l c1 op c2 = do let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm (AnnList Nothing Nothing Nothing [] []) (reLoc op) Infix [cmdArg c1, cmdArg c2] + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm noAnn (reLoc op) Infix [cmdArg c1, cmdArg c2] mkHsCasePV l c (L lm m) anns = do !cs <- getCommentsFor l @@ -1840,10 +1842,10 @@ instance DisambECP (HsCmd GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) - mkHsDoPV l Nothing stmts anns = do + mkHsDoPV l Nothing stmts tok_loc anc = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo anns stmts) - mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) Nothing Nothing [] tok_loc []) stmts) + mkHsDoPV l (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c) @@ -1937,9 +1939,9 @@ instance DisambECP (HsExpr GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) - mkHsDoPV l mod stmts anns = do + mkHsDoPV l mod stmts loc_tok anc = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo anns (DoExpr mod) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) Nothing Nothing [] loc_tok []) (DoExpr mod) stmts) mkHsParPV l lpar e rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) @@ -2030,7 +2032,7 @@ instance DisambECP (PatBuilder GhcPs) where !cs <- getCommentsFor (locA l) return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat - mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat + mkHsDoPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do @@ -3221,7 +3223,7 @@ mkTypeImpExp name = do requireExplicitNamespaces (getLocA name) return (fmap (`setRdrNameSpace` tcClsName) name) -checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs]) +checkImportSpec :: LocatedLI [LIE GhcPs] -> P (LocatedLI [LIE GhcPs]) checkImportSpec ie@(L _ specs) = case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of [] -> return ie diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 5e059c15857df362a5f5c942bf28c2a7f3e3cb98..e7f9f6ce32ddf6c7747242a535c408c0356b55f1 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -304,7 +304,7 @@ lexLHsDocString = fmap lexHsDocString -- import I (a, b, c) -- do not use here! -- -- Imports cannot have documentation comments anyway. -instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where +instance HasHaddock (LocatedLI [LocatedA (IE GhcPs)]) where addHaddock (L l_exports exports) = extendHdkA (locA l_exports) $ do exports' <- addHaddockInterleaveItems EpNoLayout mkDocIE exports diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs index 86a486782bded7639ebb9a2c583907216aeef8ad..b0b683adaa247739f041bf02d267160ba54e51ed 100644 --- a/compiler/GHC/Parser/Types.hs +++ b/compiler/GHC/Parser/Types.hs @@ -63,7 +63,7 @@ data PatBuilder p -- These instances are here so that they are not orphans type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = EpAnnCO -type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL +type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA @@ -110,4 +110,4 @@ instance Outputable DataConBuilder where ppr (InfixDataConBuilder lhs data_con rhs) = ppr lhs <+> ppr data_con <+> ppr rhs -type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL +type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 12a7ffd419f6c2795b64350fd1507ae2c7172517..85984a58607e6b920751db265aacfee7b3e7b05b 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -1293,8 +1293,8 @@ localCompletePragmas sigs = mapMaybe (getCompleteSig . unLoc) $ reverse sigs -} type AnnoBody body - = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL - , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL + = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnLW + , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 50fe3ba0c604e5b97c38d27e49d9082ff378b054..26a469c5433983b436fbc4b6901ba4609f1b5b66 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -1170,9 +1170,9 @@ filterImports -> ModIface -> ImpDeclSpec -- ^ Import spec - -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]) + -> Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs]) -- ^ Whether this is a "hiding" import list - -> RnM (Maybe (ImportListInterpretation, LocatedL [LIE GhcRn]), -- Import spec w/ Names + -> RnM (Maybe (ImportListInterpretation, LocatedLI [LIE GhcRn]), -- Import spec w/ Names ImpUserList, -- same, but designed for storage in interfaces GlobalRdrEnv) -- Same again, but in GRE form filterImports hsc_env iface decl_spec Nothing diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 7a0398b2dd3bf42f1b333c0647d0d633b1547ddf..b9d7168ee302c459455358ce1c595738fab081ed 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -177,7 +177,7 @@ type ExportOccMap = OccEnv (Name, IE GhcPs) -- that have the same occurrence name rnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedL [LIE GhcPs]) -- Nothing => no explicit export list + -> Maybe (LocatedLI [LIE GhcPs]) -- Nothing => no explicit export list -> RnM TcGblEnv -- Complains if two distinct exports have same OccName @@ -287,7 +287,7 @@ the default export. In the latter case the warning text is stored in the of a user-defined warning on default. -} -exports_from_avail :: Maybe (LocatedL [LIE GhcPs]) +exports_from_avail :: Maybe (LocatedLI [LIE GhcPs]) -- ^ 'Nothing' means no explicit export list -> GlobalRdrEnv -> ImportAvails diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 97c8dfb9c9f91fc5983939299c8703474c59eedd..644e211971b07514e0b7d5b85cb5aeee1d253b28 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -213,8 +213,8 @@ type AnnoBody body = ( Outputable (body GhcRn) , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA - , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL - , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL + , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnLW + , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnLW , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA @@ -342,7 +342,7 @@ tcGRHSList ctxt tc_body grhss res_ty -} tcDoStmts :: HsDoFlavour - -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)] + -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTc) -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 04d4b573611129122ad3a9bee22a76b1acca30a0..7f5ee2ca4b8fa10ac5c20fd70339558c3eeae52a 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -529,7 +529,7 @@ tcRnImports hsc_env import_decls -} tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedL [LIE GhcPs]) + -> Maybe (LocatedLI [LIE GhcPs]) -> [LHsDecl GhcPs] -- Declarations -> TcM TcGblEnv tcRnSrcDecls explicit_mod_hdr export_ies decls @@ -1847,7 +1847,7 @@ checkMainType tcg_env ; return lie } } } } checkMain :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedL [LIE GhcPs]) -- Export specs of Main module + -> Maybe (LocatedLI [LIE GhcPs]) -- Export specs of Main module -> TcM TcGblEnv -- If we are in module Main, check that 'main' is exported, -- and generate the runMainIO binding that calls it diff --git a/testsuite/tests/ghc-api/exactprint/T22919.stderr b/testsuite/tests/ghc-api/exactprint/T22919.stderr index a75554a642a54b2348fbedc17e5b994a82da3035..7de5790406a3a3569dc2697de1e0dd601b2cb389 100644 --- a/testsuite/tests/ghc-api/exactprint/T22919.stderr +++ b/testsuite/tests/ghc-api/exactprint/T22919.stderr @@ -73,6 +73,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr b/testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr index b9283646dc9bb5745e2ae90c11077d69bb46f084..dbb7d938d748775ee328806b8b8d0ea3fc60f5a1 100644 --- a/testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr +++ b/testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr @@ -85,6 +85,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr index 123bf5900cafaf375eb4d83dab0b70f7fe9a9a2e..6f7437117dbf5c57dbe1a7c06a03cfe46637b267 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr @@ -853,6 +853,7 @@ (Just (AddEpAnn AnnCloseC (EpaSpan { T24221.hs:29:22 }))) [] + (()) []) (EpaComments [])) @@ -1061,6 +1062,7 @@ (Just (AddEpAnn AnnCloseC (EpaSpan { T24221.hs:34:17 }))) [] + (()) []) (EpaComments [])) @@ -1281,6 +1283,7 @@ (Just (AddEpAnn AnnCloseC (EpaSpan { T24221.hs:43:3 }))) [] + (()) []) (EpaComments [])) diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr index 88f053fe284d43f46fd59c74e78a3ca4873ede36..c87a1c93fca5716152c553c3ada6df1fc0cf16b9 100644 --- a/testsuite/tests/module/mod185.stderr +++ b/testsuite/tests/module/mod185.stderr @@ -93,6 +93,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 02128d0cae1ce680379a776e1cfc43484286b53b..f8333aed8fafcf09b890a197e716c6db1a8cac66 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -2143,6 +2143,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr index b17289ef2285c49c247e2f918bf1b2e063086dc1..68c4642396ca21356be4eecfe457b3236e49b2c9 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr @@ -93,6 +93,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -210,6 +211,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -278,7 +280,8 @@ (EpaSpan { DumpParsedAstComments.hs:16:3 })) (Nothing) (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:14:7-8 }))] + [] + (EpaSpan { DumpParsedAstComments.hs:14:7-8 }) []) (DoExpr (Nothing)) @@ -291,6 +294,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -359,6 +363,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 6c1cf678c913589dd40d039294cac5d931941e1c..041e759bc53cfc3712ccce9c2caa66e8c3f0d2f8 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -37,6 +37,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -2536,6 +2537,9 @@ (Just (AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:7:23 }))) [] + ((,) + (NoEpTok) + []) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr index ed988625c9eed860a673094e5afd13086ab10026..27553bdf784117d1090ada6b724d1aec06ecd662 100644 --- a/testsuite/tests/parser/should_compile/DumpSemis.stderr +++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr @@ -100,6 +100,9 @@ (Just (AddEpAnn AnnCloseP (EpaSpan { DumpSemis.hs:5:19 }))) [] + ((,) + (NoEpTok) + []) []) (EpaComments [])) @@ -260,6 +263,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -322,7 +326,8 @@ (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) (Nothing) (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:10:7-8 }))] + [] + (EpaSpan { DumpSemis.hs:10:7-8 }) []) (DoExpr (Nothing)) @@ -335,6 +340,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -360,7 +366,8 @@ (EpaSpan { DumpSemis.hs:11:6-15 })) (Nothing) (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:11:3-4 }))] + [] + (EpaSpan { DumpSemis.hs:11:3-4 }) []) (DoExpr (Nothing)) @@ -374,10 +381,15 @@ (AddEpAnn AnnOpenC (EpaSpan { DumpSemis.hs:11:6 }))) (Just (AddEpAnn AnnCloseC (EpaSpan { DumpSemis.hs:11:15 }))) - [(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:11:8 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:11:9 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:11:10 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:11:11 }))] + [(EpTok + (EpaSpan { DumpSemis.hs:11:8 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:9 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:10 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:11 }))] + (NoEpTok) []) (EpaComments [])) @@ -560,6 +572,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -622,7 +635,8 @@ (EpaSpan { DumpSemis.hs:(16,3)-(19,3) })) (Nothing) (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:15:7-8 }))] + [] + (EpaSpan { DumpSemis.hs:15:7-8 }) []) (DoExpr (Nothing)) @@ -636,8 +650,11 @@ (AddEpAnn AnnOpenC (EpaSpan { DumpSemis.hs:16:3 }))) (Just (AddEpAnn AnnCloseC (EpaSpan { DumpSemis.hs:19:3 }))) - [(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:16:5 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:16:8 }))] + [(EpTok + (EpaSpan { DumpSemis.hs:16:5 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:16:8 }))] + (NoEpTok) []) (EpaComments [])) @@ -815,6 +832,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -877,7 +895,8 @@ (EpaSpan { DumpSemis.hs:22:10-30 })) (Nothing) (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:22:7-8 }))] + [] + (EpaSpan { DumpSemis.hs:22:7-8 }) []) (DoExpr (Nothing)) @@ -891,8 +910,11 @@ (AddEpAnn AnnOpenC (EpaSpan { DumpSemis.hs:22:10 }))) (Just (AddEpAnn AnnCloseC (EpaSpan { DumpSemis.hs:22:30 }))) - [(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:22:12 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:22:13 }))] + [(EpTok + (EpaSpan { DumpSemis.hs:22:12 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:22:13 }))] + (NoEpTok) []) (EpaComments [])) @@ -1022,6 +1044,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -1121,6 +1144,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -1221,6 +1245,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -1713,6 +1738,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -1832,6 +1858,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -1904,11 +1931,17 @@ (AddEpAnn AnnOpenC (EpaSpan { DumpSemis.hs:34:13 }))) (Just (AddEpAnn AnnCloseC (EpaSpan { DumpSemis.hs:34:31 }))) - [(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:14 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:15 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:16 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:17 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:34:18 }))] + [(EpTok + (EpaSpan { DumpSemis.hs:34:14 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:34:15 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:34:16 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:34:17 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:34:18 }))] + (NoEpTok) []) (EpaComments [])) @@ -1945,6 +1978,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -2047,6 +2081,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -2166,6 +2201,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -2273,9 +2309,13 @@ (AddEpAnn AnnOpenC (EpaSpan { DumpSemis.hs:38:4 }))) (Just (AddEpAnn AnnCloseC (EpaSpan { DumpSemis.hs:44:4 }))) - [(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:38:6 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:38:7 })) - ,(AddEpAnn AnnSemi (EpaSpan { DumpSemis.hs:38:8 }))] + [(EpTok + (EpaSpan { DumpSemis.hs:38:6 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:38:7 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:38:8 }))] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index e8f034aa9f85a56486e37faf045e1b1bbef7cba5..ddc93b5b6d65d110bcc5ea259487003e043fab85 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -1933,6 +1933,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 5b56ac562e07d54dc37138a5faf24073e1b36e5c..8c5fbb2aa8d69c999fbbe96a757c3867d153b4fe 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -1004,6 +1004,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -1729,6 +1730,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 5d9cefc0ed345c8555052c25542e4f4a6fa429fc..331baa498893d4efeaab71532d30973d3cb0c16f 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -156,6 +156,7 @@ (Just (AddEpAnn AnnCloseC (EpaSpan { T14189.hs:6:42 }))) [] + (()) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/T20718.stderr b/testsuite/tests/parser/should_compile/T20718.stderr index 25c3d9848610f5f386c645ff55b58ad5dc1178da..55dcdd7a351af23b1e1bcbce61980543de11879c 100644 --- a/testsuite/tests/parser/should_compile/T20718.stderr +++ b/testsuite/tests/parser/should_compile/T20718.stderr @@ -107,6 +107,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr index ba2975ba0e4e7eed083e35829b90eefcea9b2fa8..73cfa28c85518d9ca45474f6e4410918e07a49e9 100644 --- a/testsuite/tests/parser/should_compile/T20846.stderr +++ b/testsuite/tests/parser/should_compile/T20846.stderr @@ -96,6 +96,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout index 36e9756a32a07b672b16f69fa883705b3b86f2e8..6629e01a58377c9a5b2bd50100ab0d3d27ede00c 100644 --- a/testsuite/tests/printer/Test20297.stdout +++ b/testsuite/tests/printer/Test20297.stdout @@ -73,6 +73,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -154,7 +155,9 @@ (EpaSpan { <no location info> })) (Nothing) (Nothing) - [(AddEpAnn AnnWhere (EpaSpan { Test20297.hs:7:3-7 }))] + [] + (EpTok + (EpaSpan { Test20297.hs:7:3-7 })) []) (EpaComments [])) @@ -198,6 +201,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -273,7 +277,9 @@ (EpaSpan { Test20297.hs:11:9-26 })) (Nothing) (Nothing) - [(AddEpAnn AnnWhere (EpaSpan { Test20297.hs:10:3-7 }))] + [] + (EpTok + (EpaSpan { Test20297.hs:10:3-7 })) []) (EpaComments [(L @@ -313,6 +319,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -375,7 +382,8 @@ (EpaSpan { Test20297.hs:11:22-26 })) (Nothing) (Nothing) - [(AddEpAnn AnnDo (EpaSpan { Test20297.hs:11:19-20 }))] + [] + (EpaSpan { Test20297.hs:11:19-20 }) []) (DoExpr (Nothing)) @@ -388,6 +396,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -500,6 +509,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -575,7 +585,9 @@ (EpaSpan { <no location info> })) (Nothing) (Nothing) - [(AddEpAnn AnnWhere (EpaSpan { Test20297.ppr.hs:5:3-7 }))] + [] + (EpTok + (EpaSpan { Test20297.ppr.hs:5:3-7 })) []) (EpaComments [])) @@ -613,6 +625,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -688,7 +701,9 @@ (EpaSpan { Test20297.ppr.hs:9:7-24 })) (Nothing) (Nothing) - [(AddEpAnn AnnWhere (EpaSpan { Test20297.ppr.hs:8:3-7 }))] + [] + (EpTok + (EpaSpan { Test20297.ppr.hs:8:3-7 })) []) (EpaComments [])) @@ -722,6 +737,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -784,7 +800,8 @@ (EpaSpan { Test20297.ppr.hs:9:20-24 })) (Nothing) (Nothing) - [(AddEpAnn AnnDo (EpaSpan { Test20297.ppr.hs:9:17-18 }))] + [] + (EpaSpan { Test20297.ppr.hs:9:17-18 }) []) (DoExpr (Nothing)) @@ -797,6 +814,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/testsuite/tests/printer/Test24533.stdout b/testsuite/tests/printer/Test24533.stdout index 3377f4c5a150417d64a2d6de9a1e7fbf6628562f..d03fa3686c6566089be2536abc3912397c726f40 100644 --- a/testsuite/tests/printer/Test24533.stdout +++ b/testsuite/tests/printer/Test24533.stdout @@ -548,6 +548,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) @@ -1145,6 +1146,7 @@ (Nothing) (Nothing) [] + (NoEpTok) []) (EpaComments [])) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 90610822dd9a8eaa2b61c089f58de6135c66d53c..20901946346b7550faf428d1854a0bb0261394c2 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -219,7 +219,7 @@ setAnchorAn :: (HasTrailing an) setAnchorAn (L (EpAnn _ an _) a) anc ts cs = (L (EpAnn anc (setTrailing an ts) cs) a) -- `debug` ("setAnchorAn: anc=" ++ showAst anc) -setAnchorEpaL :: EpAnn AnnList -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> EpAnn AnnList +setAnchorEpaL :: EpAnn (AnnList l) -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> EpAnn (AnnList l) setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor = Nothing}) ts) cs -- --------------------------------------------------------------------- @@ -280,7 +280,7 @@ instance HasTrailing EpAnnSumPat where trailing _ = [] setTrailing a _ = a -instance HasTrailing AnnList where +instance HasTrailing (AnnList a) where trailing a = al_trailing a setTrailing a ts = a { al_trailing = ts } @@ -805,22 +805,6 @@ markLensAA' a l = do a' <- markKw (view l a) return (set l a' a) --- ------------------------------------- - -markEpAnnLMS'' :: (Monad m, Monoid w) - => a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m a -markEpAnnLMS'' an l kw Nothing = markEpAnnL an l kw -markEpAnnLMS'' a l kw (Just str) = do - anns <- mapM go (view l a) - return (set l anns a) - where - go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn - go (AddEpAnn kw' r) - | kw' == kw = do - r' <- printStringAtAA r str - return (AddEpAnn kw' r') - | otherwise = return (AddEpAnn kw' r) - -- --------------------------------------------------------------------- -- markEpTokenM :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) @@ -1012,21 +996,26 @@ limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = n -- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout -- al_open :: Maybe AddEpAnn, -- al_close :: Maybe AddEpAnn, --- al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword +-- al_semis :: [EpToken ";"], -- decls +-- al_rest :: !a, -- al_trailing :: [TrailingAnn] -- ^ items appearing after the -- -- list, such as '=>' for a -- -- context -- } deriving (Data,Eq) -lal_open :: Lens AnnList (Maybe AddEpAnn) +lal_open :: Lens (AnnList l) (Maybe AddEpAnn) lal_open k parent = fmap (\new -> parent { al_open = new }) (k (al_open parent)) -lal_close :: Lens AnnList (Maybe AddEpAnn) +lal_close :: Lens (AnnList l) (Maybe AddEpAnn) lal_close k parent = fmap (\new -> parent { al_close = new }) (k (al_close parent)) -lal_rest :: Lens AnnList [AddEpAnn] +lal_semis :: Lens (AnnList l) [EpToken ";"] +lal_semis k parent = fmap (\new -> parent { al_semis = new }) + (k (al_semis parent)) + +lal_rest :: Lens (AnnList l) l lal_rest k parent = fmap (\new -> parent { al_rest = new }) (k (al_rest parent)) @@ -1044,11 +1033,11 @@ lid :: Lens a a lid k parent = fmap (\new -> new) (k parent) -lfst :: Lens (a,a) a +lfst :: Lens (a,b) a lfst k parent = fmap (\new -> (new, snd parent)) (k (fst parent)) -lsnd :: Lens (a,a) a +lsnd :: Lens (b,a) a lsnd k parent = fmap (\new -> (fst parent, new)) (k (snd parent)) @@ -1323,10 +1312,6 @@ markLensTok' a l = do -- --------------------------------------------------------------------- -markEpAnnL' :: (Monad m, Monoid w) - => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) -markEpAnnL' epann l kw = markEpAnnL epann (lepa . l) kw - markEpAnnL :: (Monad m, Monoid w) => ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m ann markEpAnnL a l kw = do @@ -1335,27 +1320,29 @@ markEpAnnL a l kw = do -- ------------------------------------- -markEpAnnAllL :: (Monad m, Monoid w) - => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) -markEpAnnAllL (EpAnn anc a cs) l kw = do - anns <- mapM doit (view l 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 + +markLensFun :: (Monad m, Monoid w) + => ann -> Lens ann t -> (t -> EP w m t) -> EP w m ann +markLensFun a l f = do + t' <- f (view l a) + return (set l t' a) + +-- ------------------------------------- + +markEpAnnAllLT :: (Monad m, Monoid w, KnownSymbol tok) + => EpAnn ann -> Lens ann [EpToken tok] -> EP w m (EpAnn ann) +markEpAnnAllLT (EpAnn anc a cs) l = do + anns <- mapM markEpToken (view l a) return (EpAnn anc (set l anns a) cs) - where - doit an@(AddEpAnn ka _) - = if ka == kw - then markKw an - else return an -markEpAnnAllL' :: (Monad m, Monoid w) - => ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m ann -markEpAnnAllL' a l kw = do - anns <- mapM doit (view l a) +markEpAnnAllLT' :: (Monad m, Monoid w, KnownSymbol tok) + => ann -> Lens ann [EpToken tok] -> EP w m ann +markEpAnnAllLT' a l = do + anns <- mapM markEpToken (view l a) return (set l anns a) - where - doit an@(AddEpAnn ka _) - = if ka == kw - then markKw an - else return an markEpaLocationAll :: (Monad m, Monoid w) => [EpaLocation] -> String -> EP w m [EpaLocation] @@ -1418,37 +1405,37 @@ markKwT (AddDarrowUAnn ss) = AddDarrowUAnn <$> markKwA AnnDarrowU ss -- --------------------------------------------------------------------- markAnnList :: (Monad m, Monoid w) - => EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a) + => EpAnn (AnnList l) -> EP w m a -> EP w m (EpAnn (AnnList l), a) markAnnList ann action = do markAnnListA ann $ \a -> do r <- action return (a,r) markAnnList' :: (Monad m, Monoid w) - => AnnList -> EP w m a -> EP w m (AnnList, a) + => AnnList l -> EP w m a -> EP w m (AnnList l, a) markAnnList' ann action = do markAnnListA' ann $ \a -> do r <- action return (a,r) markAnnListA :: (Monad m, Monoid w) - => EpAnn AnnList - -> (EpAnn AnnList -> EP w m (EpAnn AnnList, a)) - -> EP w m (EpAnn AnnList, a) + => EpAnn (AnnList l) + -> (EpAnn (AnnList l) -> EP w m (EpAnn (AnnList l), a)) + -> EP w m (EpAnn (AnnList l), a) markAnnListA an action = do an0 <- markLensMAA an lal_open - an1 <- markEpAnnAllL an0 lal_rest AnnSemi + an1 <- markEpAnnAllLT an0 lal_semis (an2, r) <- action an1 an3 <- markLensMAA an2 lal_close return (an3, r) markAnnListA' :: (Monad m, Monoid w) - => AnnList - -> (AnnList -> EP w m (AnnList, a)) - -> EP w m (AnnList, a) + => AnnList l + -> (AnnList l -> EP w m (AnnList l, a)) + -> EP w m (AnnList l , a) markAnnListA' an action = do an0 <- markLensMAA' an lal_open - an1 <- markEpAnnAllL' an0 lal_rest AnnSemi + an1 <- markEpAnnAllLT' an0 lal_semis (an2, r) <- action an1 an3 <- markLensMAA' an2 lal_close return (an3, r) @@ -2661,7 +2648,7 @@ instance ExactPrint (HsLocalBinds GhcPs) where exact (HsValBinds an valbinds) = do debugM $ "exact HsValBinds: an=" ++ showAst an - an0 <- markEpAnnL' an lal_rest AnnWhere + an0 <- markLensFun' an lal_rest markEpToken case al_anchor $ anns an of Just anc -> do @@ -2680,7 +2667,7 @@ instance ExactPrint (HsLocalBinds GhcPs) where exact (HsIPBinds an bs) = do (an2,bs') <- markAnnListA an $ \an0 -> do - an1 <- markEpAnnL' an0 lal_rest AnnWhere + an1 <- markLensFun' an0 lal_rest markEpToken bs' <- markAnnotated bs return (an1, bs') return (HsIPBinds an2 bs') @@ -3307,23 +3294,24 @@ instance ExactPrint (HsExpr GhcPs) where -- --------------------------------------------------------------------- exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => AnnList -> HsDoFlavour -> LocatedAn an a - -> EP w m (AnnList, LocatedAn an a) -exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an GhciStmtCtxt stmts = markEpAnnL an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >>= \an0 -> markMaybeDodgyStmts an0 stmts + => AnnList EpaLocation -> HsDoFlavour -> LocatedAn an a + -> EP w m (AnnList EpaLocation, LocatedAn an a) +exactDo an (DoExpr m) stmts = exactMdo an m "do" >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an GhciStmtCtxt stmts = markLensFun an lal_rest (\l -> printStringAtAA l "do") >>= + \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an (MDoExpr m) stmts = exactMdo an m "mdo" >>= \an0 -> markMaybeDodgyStmts an0 stmts exactDo an ListComp stmts = markMaybeDodgyStmts an stmts exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts exactMdo :: (Monad m, Monoid w) - => AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m AnnList -exactMdo an Nothing kw = markEpAnnL an lal_rest kw -exactMdo an (Just module_name) kw = markEpAnnLMS'' an lal_rest kw (Just n) + => AnnList EpaLocation -> Maybe ModuleName -> String -> EP w m (AnnList EpaLocation) +exactMdo an Nothing kw = markLensFun an lal_rest (\l -> printStringAtAA l kw) +exactMdo an (Just module_name) kw = markLensFun an lal_rest (\l -> printStringAtAA l n) where - n = (moduleNameString module_name) ++ "." ++ (keywordToString kw) + n = (moduleNameString module_name) ++ "." ++ kw markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => AnnList -> LocatedAn an a -> EP w m (AnnList, LocatedAn an a) + => AnnList l -> LocatedAn an a -> EP w m (AnnList l, LocatedAn an a) markMaybeDodgyStmts an stmts = if notDodgy stmts then do @@ -3603,7 +3591,7 @@ instance ExactPrint (HsCmd GhcPs) where exact (HsCmdDo an es) = do debugM $ "HsCmdDo" - an0 <- markEpAnnL an lal_rest AnnDo + an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do") es' <- markAnnotated es return (HsCmdDo an0 es') @@ -3612,8 +3600,8 @@ instance ExactPrint (HsCmd GhcPs) where instance ( ExactPrint (LocatedA (body GhcPs)), Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, - Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL, - (ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW, + (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _s = a @@ -3635,11 +3623,11 @@ instance ( body' <- markAnnotated body return (BodyStmt a body' b c) - exact (LetStmt an binds) = do + exact (LetStmt tlet binds) = do debugM $ "LetStmt" - an0 <- markEpToken an + tlet' <- markEpToken tlet binds' <- markAnnotated binds - return (LetStmt an0 binds') + return (LetStmt tlet' binds') exact (ParStmt a pbs b c) = do debugM $ "ParStmt" @@ -3654,7 +3642,7 @@ instance ( exact (RecStmt an stmts a b c d e) = do debugM $ "RecStmt" - an0 <- markEpAnnL an lal_rest AnnRec + an0 <- markLensFun an lal_rest markEpToken (an1, stmts') <- markAnnList' an0 (markAnnotated stmts) return (RecStmt an1 stmts' a b c d e) @@ -4590,33 +4578,33 @@ instance ExactPrint (SourceText, RuleName) where -- applied. -- --------------------------------------------------------------------- -instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where +instance ExactPrint (LocatedLI [LocatedA (IE GhcPs)]) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L an ies) = do debugM $ "LocatedL [LIE" - an0 <- markEpAnnL' an lal_rest AnnHiding + an0 <- markLensFun' an (lal_rest . lfst) markEpToken p <- getPosP debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p (an1, ies') <- markAnnList an0 (markAnnotated (filter notIEDoc ies)) return (L an1 ies') instance (ExactPrint (Match GhcPs (LocatedA body))) - => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where + => ExactPrint (LocatedLW [LocatedA (Match GhcPs (LocatedA body))]) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L an a) = do debugM $ "LocatedL [LMatch" -- TODO: markAnnList? - an0 <- markEpAnnAllL an lal_rest AnnWhere + an0 <- markLensFun' an lal_rest markEpToken an1 <- markLensMAA an0 lal_open - an2 <- markEpAnnAllL an1 lal_rest AnnSemi + an2 <- markEpAnnAllLT an1 lal_semis a' <- markAnnotated a an3 <- markLensMAA an2 lal_close return (L an3 a') -instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where +instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L an stmts) = do @@ -4632,7 +4620,7 @@ instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr Gh markAnnotated stmts return (L an'' stmts') -instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where +instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L ann es) = do diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index e3d52b4612dd75164d310057e875166125164f94..dc3721754916b5b31be362733744703cadefde8d 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -36,9 +36,9 @@ import GHC.Data.FastString _tt :: IO () -- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/" -_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/" +-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/" -- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib" --- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib" +_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib" -- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1) -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2) @@ -105,7 +105,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Ppr012.hs" Nothing -- "../../testsuite/tests/printer/Ppr013.hs" Nothing -- "../../testsuite/tests/printer/Ppr014.hs" Nothing - "../../testsuite/tests/printer/Ppr015.hs" Nothing + -- "../../testsuite/tests/printer/Ppr015.hs" Nothing -- "../../testsuite/tests/printer/Ppr016.hs" Nothing -- "../../testsuite/tests/printer/Ppr017.hs" Nothing -- "../../testsuite/tests/printer/Ppr018.hs" Nothing @@ -199,8 +199,11 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test19834.hs" Nothing -- "../../testsuite/tests/printer/Test19840.hs" Nothing -- "../../testsuite/tests/printer/Test19850.hs" Nothing + "../../testsuite/tests/printer/Test20247.hs" Nothing -- "../../testsuite/tests/printer/Test20258.hs" Nothing + -- "../../testsuite/tests/printer/Test20297.hs" Nothing -- "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing + -- "../../testsuite/tests/printer/PprRecordSemi.hs" Nothing -- "../../testsuite/tests/printer/PprSemis.hs" Nothing -- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing -- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing @@ -527,10 +530,8 @@ changeLocalDecls libdir (L l p) = do (os:oldSigs) = concatMap decl2Sig oldDecls' os' = setEntryDP os (DifferentLine 2 0) let sortKey = captureOrderBinds decls - let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van - let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 5) [])) a b c dd) cs) - -- let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van - -- let van' = (EpAnn anc (AnnList (Just (EpaDelta (DifferentLine 1 5) [])) a b c dd) cs) + let (EpAnn anc (AnnList (Just _) a b c dd e) cs) = van + let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 5) [])) a b c dd e) cs) let binds' = (HsValBinds van' (ValBinds sortKey (decl':oldBinds) (sig':os':oldSigs))) @@ -558,7 +559,9 @@ changeLocalDecls2 libdir (L l p) = do let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 5) []) let an = EpAnn anc (AnnList (Just anc2) Nothing Nothing - [AddEpAnn AnnWhere (EpaDelta noSrcSpan (SameLine 0) [])] []) + [] + (EpTok (EpaDelta noSrcSpan (SameLine 0) [])) + []) emptyComments let decls = [s,d] let sortKey = captureOrderBinds decls @@ -884,7 +887,8 @@ addHiding1 _libdir (L l p) = do (AnnList Nothing (Just (AddEpAnn AnnOpenP d1)) (Just (AddEpAnn AnnCloseP d0)) - [(AddEpAnn AnnHiding d1)] + [] + (EpTok d1,[]) []) emptyComments) [v1,v2] imp1' = imp1 { ideclImportList = Just (EverythingBut,impHiding)} @@ -909,7 +913,8 @@ addHiding2 _libdir top = do (AnnList Nothing (Just (AddEpAnn AnnOpenP d1)) (Just (AddEpAnn AnnCloseP d0)) - [(AddEpAnn AnnHiding d1)] + [] + (EpTok d1, []) []) emptyComments) n1 = L (noAnnSrcSpanDP0) (mkVarUnqual (mkFastString "n1")) diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index aaf7d846187aafae370ee5a782bee2491bf18dfb..434fb31278fa560e95a221e264201b208d078345 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -1081,33 +1082,34 @@ replaceDeclsValbinds w (EmptyLocalBinds _) new sortKey = captureOrderBinds new in (HsValBinds an (ValBinds sortKey decs sigs)) -oldWhereAnnotation :: EpAnn AnnList -> WithWhere -> RealSrcSpan -> (EpAnn AnnList) +oldWhereAnnotation :: EpAnn (AnnList (EpToken "where")) + -> WithWhere -> RealSrcSpan -> (EpAnn (AnnList (EpToken "where"))) oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = an' -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, -- change the AnnList anchor to have the correct DP too where - (AnnList ancl o c _r t) = an + (AnnList ancl o c s _r t) = an w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta noSrcSpan (SameLine 0) [])] - WithoutWhere -> [] + WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) + WithoutWhere -> NoEpTok (anc', ancl') = case ww of WithWhere -> (anc, ancl) WithoutWhere -> (anc, ancl) an' = EpAnn anc' - (AnnList ancl' o c w t) + (AnnList ancl' o c s w t) cs -newWhereAnnotation :: WithWhere -> (EpAnn AnnList) +newWhereAnnotation :: WithWhere -> (EpAnn (AnnList (EpToken "where"))) newWhereAnnotation ww = an where anc = EpaDelta noSrcSpan (DifferentLine 1 3) [] anc2 = EpaDelta noSrcSpan (DifferentLine 1 5) [] w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta noSrcSpan (SameLine 0) [])] - WithoutWhere -> [] + WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) + WithoutWhere -> NoEpTok an = EpAnn anc - (AnnList (Just anc2) Nothing Nothing w []) + (AnnList (Just anc2) Nothing Nothing [] w []) emptyComments -- --------------------------------------------------------------------- diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index 762fea71d07cb23f28120197ab451087a2e28860..65bfef2b60b3a1a0bc063fd2c147da56a61ffe3b 100644 --- a/utils/check-exact/Utils.hs +++ b/utils/check-exact/Utils.hs @@ -246,7 +246,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining addCommentsListItem :: EpAnn AnnListItem -> State [LEpaComment] (EpAnn AnnListItem) addCommentsListItem = addComments - addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) + addCommentsList :: EpAnn (AnnList ()) -> State [LEpaComment] (EpAnn (AnnList ())) addCommentsList = addComments addCommentsGrhs :: EpAnn GrhsAnn -> State [LEpaComment] (EpAnn GrhsAnn)