diff options
| author | GHC GitLab CI <ghc-ci@gitlab-haskell.org> | 2021-03-23 08:32:31 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-25 04:53:16 -0400 |
| commit | 1350a5cd730f1cbbe306b849def26bfcd119c103 (patch) | |
| tree | 45c8b4ef2cd4b09d6f9a24da905a1be5ff5ee616 | |
| parent | 0029df2bd52aa7f93e2254a369428e4261e5d3ae (diff) | |
| download | haskell-1350a5cd730f1cbbe306b849def26bfcd119c103.tar.gz | |
EPA : Remove ApiAnn from ParsedModule
All the comments are now captured in the AST, there is no need for a
side-channel structure for them.
29 files changed, 202 insertions, 1438 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 7a237b2146..0c55bfbea1 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -283,7 +283,7 @@ module GHC ( parser, -- * API Annotations - ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), + AnnKeywordId(..),AnnotationComment(..), -- * Miscellaneous --sessionHscEnv, @@ -1021,9 +1021,7 @@ class TypecheckedMod m => DesugaredMod m where data ParsedModule = ParsedModule { pm_mod_summary :: ModSummary , pm_parsed_source :: ParsedSource - , pm_extra_src_files :: [FilePath] - , pm_annotations :: ApiAnns } - -- See Note [Api annotations] in GHC.Parser.Annotation + , pm_extra_src_files :: [FilePath] } instance ParsedMod ParsedModule where modSummary m = pm_mod_summary m @@ -1115,8 +1113,7 @@ parseModule ms = do hsc_env <- getSession let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } hpm <- liftIO $ hscParse hsc_env_tmp ms - return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm) - (hpm_annotations hpm)) + return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)) -- See Note [Api annotations] in GHC.Parser.Annotation -- | Typecheck and rename a parsed module. @@ -1130,8 +1127,7 @@ typecheckModule pmod = do (tc_gbl_env, rn_info) <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } + hpm_src_files = pm_extra_src_files pmod } details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index daf53a502f..07c56bb36a 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -773,8 +773,7 @@ summariseRequirement pn mod_name = do hsmodDeprecMessage = Nothing, hsmodHaddockModHeader = Nothing }), - hpm_src_files = [], - hpm_annotations = ApiAnns [] + hpm_src_files = [] }), ms_hspp_file = "", -- none, it came inline ms_hspp_opts = dflags, @@ -884,8 +883,7 @@ hsModuleToModSummary pn hsc_src modname -- This is our hack to get the parse tree to the right spot ms_parsed_mod = Just (HsParsedModule { hpm_module = hsmod, - hpm_src_files = [], -- TODO if we preprocessed it - hpm_annotations = ApiAnns [] -- BOGUS + hpm_src_files = [] -- TODO if we preprocessed it }), ms_hs_date = time, ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index c060f69c87..0ef4f10719 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -217,7 +217,7 @@ import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) import Data.Data hiding (Fixity, TyCon) -import Data.Maybe ( fromJust, fromMaybe ) +import Data.Maybe ( fromJust ) import Data.List ( nub, isPrefixOf, partition ) import Control.Monad import Data.IORef @@ -462,13 +462,9 @@ hscParse' mod_summary -- filter them out: srcs2 <- liftIO $ filterM doesFileExist srcs1 - let api_anns = ApiAnns { - apiAnnRogueComments = (fromMaybe [] (header_comments pst)) ++ comment_q pst - } - res = HsParsedModule { + let res = HsParsedModule { hpm_module = rdr_module, - hpm_src_files = srcs2, - hpm_annotations = api_anns + hpm_src_files = srcs2 } -- apply parse transformation of plugins diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 95cf14a616..26022e96de 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -166,13 +166,10 @@ pp_nonnull xs = vcat (map ppr xs) data HsParsedModule = HsParsedModule { hpm_module :: Located HsModule, - hpm_src_files :: [FilePath], + hpm_src_files :: [FilePath] -- ^ extra source files (e.g. from #includes). The lexer collects -- these from '# <file> <line>' pragmas, which the C preprocessor -- leaves behind. These files and their timestamps are stored in -- the .hi file, so that we can force recompilation if any of -- them change (#3589) - hpm_annotations :: ApiAnns - -- See note [Api annotations] in GHC.Parser.Annotation } - diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index 329b2d9308..18605d3532 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -57,6 +57,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` annotationAddApiAnn `extQ` annotationGrhsAnn `extQ` annotationApiAnnHsCase + `extQ` annotationApiAnnHsLet `extQ` annotationAnnList `extQ` annotationApiAnnImportDecl `extQ` annotationAnnParen @@ -237,6 +238,9 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 annotationApiAnnHsCase :: ApiAnn' ApiAnnHsCase -> SDoc annotationApiAnnHsCase = annotation' (text "ApiAnn' ApiAnnHsCase") + annotationApiAnnHsLet :: ApiAnn' AnnsLet -> SDoc + annotationApiAnnHsLet = annotation' (text "ApiAnn' AnnsLet") + annotationAnnList :: ApiAnn' AnnList -> SDoc annotationAnnList = annotation' (text "ApiAnn' AnnList") diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index f786940591..b9bae7a1f7 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1197,6 +1197,8 @@ topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) } : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsA $2 $3 ; return ($1 `snocOL` t) }} | {- empty -} { nilOL } + +-- Each topdecl accumulates prior comments topdecl_cs :: { LHsDecl GhcPs } topdecl_cs : topdecl {% commentsPA $1 } diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 3dd3b3302b..a860e3edb9 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -4,10 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} module GHC.Parser.Annotation ( - -- * Out-of-tree API Annotations. Exist for the duration of !5158, - -- * will be removed by !2418 - ApiAnns(..), - -- * Core API Annotation types AnnKeywordId(..), AnnotationComment(..), AnnotationCommentTok(..), @@ -162,12 +158,6 @@ The wiki page describing this feature is https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations -} --- --------------------------------------------------------------------- - -data ApiAnns = - ApiAnns - { apiAnnRogueComments :: [LAnnotationComment] - } -- -------------------------------------------------------------------- diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index bfebbfa411..634cd10207 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -2932,7 +2932,7 @@ instance MonadP P where POk s { header_comments = header_comments', comment_q = comment_q' - } (AnnCommentsBalanced [] (reverse newAnns)) + } (AnnCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns)) getCommentsFor :: (MonadP m) => SrcSpan -> m ApiAnnComments getCommentsFor (RealSrcSpan l _) = allocateCommentsP l @@ -3496,8 +3496,8 @@ allocateFinalComments ss comment_q mheader_comments = comment_q'= before in case mheader_comments of - Nothing -> (Just newAnns, comment_q', []) - Just _ -> (mheader_comments, comment_q', newAnns) + Nothing -> (Just newAnns, [], comment_q') + Just _ -> (mheader_comments, [], comment_q' ++ newAnns) commentToAnnotation :: RealLocated Token -> LAnnotationComment commentToAnnotation (L l (ITdocCommentNext s ll)) = mkLAnnotationComment l ll (AnnDocCommentNext s) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 9dde6faeb8..9ac689c4d4 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2826,7 +2826,7 @@ instance MonadP PV where PV_Ok s { pv_header_comments = header_comments', pv_comment_q = comment_q' - } (AnnCommentsBalanced [] (reverse newAnns)) + } (AnnCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns)) {- Note [Parser-Validator Hint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/testsuite/tests/ghc-api/annotations/.gitignore b/testsuite/tests/ghc-api/annotations/.gitignore deleted file mode 100644 index 320a756e5c..0000000000 --- a/testsuite/tests/ghc-api/annotations/.gitignore +++ /dev/null @@ -1,26 +0,0 @@ -annotations -parseTree -comments -exampleTest -listcomps -boolFormula -t10255 -t10268 -t10269 -t10278 -t10280 -t10307 -t10309 -t10312 -t10354 -t10357 -t10358 -t10396 -t10399 -t11430 -load-main -stringSource -*.hi -*.o -*.run.* -*.normalised diff --git a/testsuite/tests/ghc-api/annotations/CheckUtils.hs b/testsuite/tests/ghc-api/annotations/CheckUtils.hs deleted file mode 100644 index d3a2b3d80e..0000000000 --- a/testsuite/tests/ghc-api/annotations/CheckUtils.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir and the file to be checked as --- the command line arguments. -module CheckUtils where - -import Data.Data -import Data.List -import System.IO -import GHC -import GHC.Types.Basic -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Parser.Annotation -import GHC.Data.Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Dynamic ( fromDynamic,Dynamic ) - -_main::IO() -_main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName - -testOneFile libdir fileName = do - ((anns,cs),p) <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - return (pm_annotations p,p) - - let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) - - problems = filter (\(s,a) -> not (Set.member s spans)) - $ getAnnSrcSpans (anns,cs) - - exploded = [((kw,ss),[anchor]) - | ((anchor,kw),sss) <- Map.toList anns,ss <- sss] - - exploded' = Map.toList $ Map.fromListWith (++) exploded - - problems' = filter (\(_,anchors) - -> not (any (\a -> Set.member a spans) anchors)) - exploded' - - putStrLn "---Problems---------------------" - putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems]) - putStrLn "---Problems'--------------------" - putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems']) - putStrLn "--------------------------------" - putStrLn (intercalate "\n" [showAnns anns]) - - where - getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] - getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns - - getAllSrcSpans :: (Data t) => t -> [SrcSpan] - getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast - where - getSrcSpan :: SrcSpan -> [SrcSpan] - getSrcSpan ss = [ss] - - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPprUnsafe a - - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.stderr b/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.stderr deleted file mode 100644 index 42e3143635..0000000000 --- a/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.stderr +++ /dev/null @@ -1,521 +0,0 @@ - -==================== Parser AST ==================== - -(L - { InTreeAnnotations1.hs:1:1 } - (HsModule - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:1:1 } - (UnchangedAnchor)) - (AnnsModule - [(AddApiAnn AnnModule (AR { InTreeAnnotations1.hs:2:1-6 })) - ,(AddApiAnn AnnWhere (AR { InTreeAnnotations1.hs:2:27-31 }))] - (AnnList - (Nothing) - (Nothing) - (Nothing) - [] - [])) - (AnnCommentsBalanced - [] - [(L - (Anchor - { InTreeAnnotations1.hs:9:1 } - (UnchangedAnchor)) - (AnnComment - (AnnEofComment) - { InTreeAnnotations1.hs:9:1 }))])) - (VirtualBraces - (1)) - (Just - (L - { InTreeAnnotations1.hs:2:8-25 } - {ModuleName: InTreeAnnotations1})) - (Nothing) - [] - [(L - (SrcSpanAnn (ApiAnn - (Anchor - { InTreeAnnotations1.hs:4:1-31 } - (UnchangedAnchor)) - (AnnListItem - []) - (AnnComments - [])) { InTreeAnnotations1.hs:4:1-31 }) - (ValD - (NoExtField) - (FunBind - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:1-3 }) - (Unqual - {OccName: foo})) - (MG - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:1-31 }) - [(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:1-31 }) - (Match - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:4:1-31 } - (UnchangedAnchor)) - [] - (AnnComments - [])) - (FunRhs - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:1-3 }) - (Unqual - {OccName: foo})) - (Prefix) - (NoSrcStrict)) - [(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:5-11 }) - (AsPat - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:4:5-11 } - (UnchangedAnchor)) - [(AddApiAnn AnnAt (AR { InTreeAnnotations1.hs:4:6 }))] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:5 }) - (Unqual - {OccName: a})) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:7-11 }) - (TuplePat - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:4:7-11 } - (UnchangedAnchor)) - [(AddApiAnn AnnOpenP (AR { InTreeAnnotations1.hs:4:7 })) - ,(AddApiAnn AnnCloseP (AR { InTreeAnnotations1.hs:4:11 }))] - (AnnComments - [])) - [(L - (SrcSpanAnn (ApiAnn - (Anchor - { InTreeAnnotations1.hs:4:8 } - (UnchangedAnchor)) - (AnnListItem - [(AddCommaAnn - (AR { InTreeAnnotations1.hs:4:9 }))]) - (AnnComments - [])) { InTreeAnnotations1.hs:4:8 }) - (WildPat - (NoExtField))) - ,(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:10 }) - (WildPat - (NoExtField)))] - (Boxed))))) - ,(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:13-16 }) - (BangPat - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:4:13-16 } - (UnchangedAnchor)) - [(AddApiAnn AnnBang (AR { InTreeAnnotations1.hs:4:13 }))] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:14-16 }) - (LitPat - (NoExtField) - (HsString - (SourceText "a") - {FastString: "a"}))))) - ,(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:18-19 }) - (LazyPat - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:4:18-19 } - (UnchangedAnchor)) - [(AddApiAnn AnnTilde (AR { InTreeAnnotations1.hs:4:18 }))] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:19 }) - (VarPat - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:19 }) - (Unqual - {OccName: x}))))))] - (GRHSs - (NoExtField) - [(L - { InTreeAnnotations1.hs:4:21-31 } - (GRHS - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:4:21-31 } - (UnchangedAnchor)) - (GrhsAnn - (Nothing) - (AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:4:21 }))) - (AnnComments - [])) - [] - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:23-31 }) - (HsVar - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:23-31 }) - (Unqual - {OccName: undefined}))))))] - (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) - []))) - ,(L - (SrcSpanAnn (ApiAnn - (Anchor - { InTreeAnnotations1.hs:6:1-27 } - (UnchangedAnchor)) - (AnnListItem - []) - (AnnComments - [])) { InTreeAnnotations1.hs:6:1-27 }) - (TyClD - (NoExtField) - (DataDecl - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:6:1-27 } - (UnchangedAnchor)) - [(AddApiAnn AnnData (AR { InTreeAnnotations1.hs:6:1-4 })) - ,(AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:6:8 }))] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:6 }) - (Unqual - {OccName: T})) - (HsQTvs - (NoExtField) - []) - (Prefix) - (HsDataDefn - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:6:1-27 } - (UnchangedAnchor)) - [(AddApiAnn AnnData (AR { InTreeAnnotations1.hs:6:1-4 })) - ,(AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:6:8 }))] - (AnnComments - [])) - (DataType) - (Nothing) - (Nothing) - (Nothing) - [(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:10-27 }) - (ConDeclH98 - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:6:10-27 } - (UnchangedAnchor)) - [] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:10-12 }) - (Unqual - {OccName: MkT})) - (False) - [] - (Nothing) - (RecCon - (L - (SrcSpanAnn (ApiAnn - (Anchor - { InTreeAnnotations1.hs:6:14 } - (UnchangedAnchor)) - (AnnList - (Just - (Anchor - { InTreeAnnotations1.hs:6:16-25 } - (UnchangedAnchor))) - (Just - (AddApiAnn AnnOpenC (AR { InTreeAnnotations1.hs:6:14 }))) - (Just - (AddApiAnn AnnCloseC (AR { InTreeAnnotations1.hs:6:27 }))) - [] - []) - (AnnComments - [])) { InTreeAnnotations1.hs:6:14-27 }) - [(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:16-25 }) - (ConDeclField - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:6:16-18 } - (UnchangedAnchor)) - [(AddApiAnn AnnDcolon (AR { InTreeAnnotations1.hs:6:20-21 }))] - (AnnComments - [])) - [(L - { InTreeAnnotations1.hs:6:16 } - (FieldOcc - (NoExtField) - (L - (SrcSpanAnn (ApiAnn - (Anchor - { InTreeAnnotations1.hs:6:16 } - (UnchangedAnchor)) - (NameAnnTrailing - [(AddCommaAnn - (AR { InTreeAnnotations1.hs:6:17 }))]) - (AnnComments - [])) { InTreeAnnotations1.hs:6:16 }) - (Unqual - {OccName: x})))) - ,(L - { InTreeAnnotations1.hs:6:18 } - (FieldOcc - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:18 }) - (Unqual - {OccName: y}))))] - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:23-25 }) - (HsTyVar - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:6:23-25 } - (UnchangedAnchor)) - [] - (AnnComments - [])) - (NotPromoted) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:23-25 }) - (Unqual - {OccName: Int})))) - (Nothing)))])) - (Nothing)))] - [])))) - ,(L - (SrcSpanAnn (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:1-43 } - (UnchangedAnchor)) - (AnnListItem - []) - (AnnComments - [])) { InTreeAnnotations1.hs:8:1-43 }) - (ValD - (NoExtField) - (FunBind - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:1 }) - (Unqual - {OccName: f})) - (MG - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:1-43 }) - [(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:1-43 }) - (Match - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:1-43 } - (UnchangedAnchor)) - [] - (AnnComments - [])) - (FunRhs - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:1 }) - (Unqual - {OccName: f})) - (Prefix) - (NoSrcStrict)) - [(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:3-35 }) - (ParPat - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:3-35 } - (UnchangedAnchor)) - (AnnParen - (AnnParens) - (AR { InTreeAnnotations1.hs:8:3 }) - (AR { InTreeAnnotations1.hs:8:35 })) - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:4-34 }) - (ConPat - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:4-34 } - (UnchangedAnchor)) - [(AddApiAnn AnnOpenC (AR { InTreeAnnotations1.hs:8:8 })) - ,(AddApiAnn AnnCloseC (AR { InTreeAnnotations1.hs:8:34 }))] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:4-6 }) - (Unqual - {OccName: MkT})) - (RecCon - (HsRecFields - [(L - (SrcSpanAnn (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:10-15 } - (UnchangedAnchor)) - (AnnListItem - [(AddCommaAnn - (AR { InTreeAnnotations1.hs:8:16 }))]) - (AnnComments - [])) { InTreeAnnotations1.hs:8:10-15 }) - (HsRecField - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:10 } - (UnchangedAnchor)) - [(AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:8:12 }))] - (AnnComments - [])) - (L - { InTreeAnnotations1.hs:8:10 } - (FieldOcc - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:10 }) - (Unqual - {OccName: x})))) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:14-15 }) - (BangPat - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:14-15 } - (UnchangedAnchor)) - [(AddApiAnn AnnBang (AR { InTreeAnnotations1.hs:8:14 }))] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:15 }) - (VarPat - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:15 }) - (Unqual - {OccName: v})))))) - (False))) - ,(L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:18-32 }) - (HsRecField - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:18 } - (UnchangedAnchor)) - [(AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:8:20 }))] - (AnnComments - [])) - (L - { InTreeAnnotations1.hs:8:18 } - (FieldOcc - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:18 }) - (Unqual - {OccName: y})))) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:22-32 }) - (ViewPat - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:22-32 } - (UnchangedAnchor)) - [(AddApiAnn AnnRarrow (AR { InTreeAnnotations1.hs:8:29-30 }))] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:22-27 }) - (HsVar - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:22-27 }) - (Unqual - {OccName: negate})))) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:32 }) - (VarPat - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:32 }) - (Unqual - {OccName: w})))))) - (False)))] - (Nothing)))))))] - (GRHSs - (NoExtField) - [(L - { InTreeAnnotations1.hs:8:37-43 } - (GRHS - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:37-43 } - (UnchangedAnchor)) - (GrhsAnn - (Nothing) - (AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:8:37 }))) - (AnnComments - [])) - [] - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:39-43 }) - (OpApp - (ApiAnn - (Anchor - { InTreeAnnotations1.hs:8:39-43 } - (UnchangedAnchor)) - [] - (AnnComments - [])) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:39 }) - (HsVar - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:39 }) - (Unqual - {OccName: v})))) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:41 }) - (HsVar - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:41 }) - (Unqual - {OccName: +})))) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:43 }) - (HsVar - (NoExtField) - (L - (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:43 }) - (Unqual - {OccName: w}))))))))] - (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) - [])))] - (Nothing) - (Nothing))) diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile deleted file mode 100644 index 23151ea43a..0000000000 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -clean: - rm -f *.o *.hi - rm -f annotations comments - rm -f stringSource - -.PHONY: annotations -annotations: - rm -f annotations.o annotations.hi - '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc annotations - ./annotations "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" - -.PHONY: comments -comments: - rm -f comments.o comments.hi - '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc comments - ./comments "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" - -# .PHONY: T10313 -# T10313: -# rm -f stringSource.o stringSource.hi -# '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc stringSource -# ./stringSource "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10313 - -# .PHONY: T11430 -# T11430: -# rm -f t11430.o t11430.hi t11430 -# '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t11430 -# ./t11430 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11430 diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T deleted file mode 100644 index b99afdab4a..0000000000 --- a/testsuite/tests/ghc-api/annotations/all.T +++ /dev/null @@ -1,4 +0,0 @@ -test('comments', [normalise_slashes, - extra_files(['CommentsTest.hs']), - ignore_stderr], makefile_test, ['comments']) -test('InTreeAnnotations1',normal, compile, ['-dsuppress-uniques -ddump-parsed-ast']) diff --git a/testsuite/tests/ghc-api/annotations/bundle-export.stdout b/testsuite/tests/ghc-api/annotations/bundle-export.stdout deleted file mode 100644 index e7bff3db75..0000000000 --- a/testsuite/tests/ghc-api/annotations/bundle-export.stdout +++ /dev/null @@ -1,37 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((BundleExport.hs:1:1,AnnModule), [BundleExport.hs:2:1-6]), -((BundleExport.hs:1:1,AnnWhere), [BundleExport.hs:2:37-41]), -((BundleExport.hs:2:20-35,AnnCloseP), [BundleExport.hs:2:35]), -((BundleExport.hs:2:20-35,AnnOpenP), [BundleExport.hs:2:20]), -((BundleExport.hs:2:21-28,AnnCloseP), [BundleExport.hs:2:28]), -((BundleExport.hs:2:21-28,AnnComma), [BundleExport.hs:2:25, BundleExport.hs:2:29]), -((BundleExport.hs:2:21-28,AnnDotdot), [BundleExport.hs:2:23-24]), -((BundleExport.hs:2:21-28,AnnOpenP), [BundleExport.hs:2:22]), -((BundleExport.hs:2:31-34,AnnCloseP), [BundleExport.hs:2:34]), -((BundleExport.hs:2:31-34,AnnOpenP), [BundleExport.hs:2:32]), -((BundleExport.hs:4:1-10,AnnData), [BundleExport.hs:4:1-4]), -((BundleExport.hs:4:1-10,AnnEqual), [BundleExport.hs:4:8]), -((BundleExport.hs:4:1-10,AnnSemi), [BundleExport.hs:6:1]), -((BundleExport.hs:6:1-10,AnnData), [BundleExport.hs:6:1-4]), -((BundleExport.hs:6:1-10,AnnEqual), [BundleExport.hs:6:8]), -((BundleExport.hs:6:1-10,AnnSemi), [BundleExport.hs:8:1]), -((BundleExport.hs:8:1-13,AnnEqual), [BundleExport.hs:8:11]), -((BundleExport.hs:8:1-13,AnnPattern), [BundleExport.hs:8:1-7]), -((BundleExport.hs:8:1-13,AnnSemi), [BundleExport.hs:9:1]), -((BundleExport.hs:9:1-13,AnnEqual), [BundleExport.hs:9:11]), -((BundleExport.hs:9:1-13,AnnPattern), [BundleExport.hs:9:1-7]), -((BundleExport.hs:9:1-13,AnnSemi), [BundleExport.hs:10:1]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "BundleExport.hs" 10 1 diff --git a/testsuite/tests/ghc-api/annotations/comments.hs b/testsuite/tests/ghc-api/annotations/comments.hs deleted file mode 100644 index d8c68594d0..0000000000 --- a/testsuite/tests/ghc-api/annotations/comments.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List (intercalate) -import System.IO -import GHC -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Data.Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir] <- getArgs - testOneFile libdir "CommentsTest" True - testOneFile libdir "CommentsTest" False - -testOneFile libdir fileName useHaddock = do - p <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - let dflags' = if useHaddock - then gopt_set (gopt_set dflags Opt_Haddock) - Opt_KeepRawTokenStream - else gopt_set (gopt_unset dflags Opt_Haddock) - Opt_KeepRawTokenStream - setSessionDynFlags dflags' - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - t <- typecheckModule p - d <- desugarModule t - l <- loadModule d - let ts=typecheckedSource l - r =renamedSource l - -- liftIO (putStr (showSDocDebug (ppr ts))) - return (pm_annotations p) - - let anns = p - -- ann_comments = apiAnnComments anns - ann_comments = Map.empty - ann_rcomments = apiAnnRogueComments anns - comments = - map (\(s,v) -> (RealSrcSpan s Nothing, v)) (Map.toList ann_comments) - ++ - [(noSrcSpan, ann_rcomments)] - - putStrLn (intercalate "\n" [showAnns comments]) - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\(s,v) - -> ("( " ++ pp s ++" =\n[" ++ showToks v ++ "])\n")) - $ anns) - ++ "]\n" - -showToks ts = intercalate ",\n\n" - $ map (\(L p t) -> "(" ++ pp p ++ "," ++ show t ++ ")") ts - -pp a = showPprUnsafe a diff --git a/testsuite/tests/ghc-api/annotations/comments.stdout b/testsuite/tests/ghc-api/annotations/comments.stdout deleted file mode 100644 index 1b7ed7061a..0000000000 --- a/testsuite/tests/ghc-api/annotations/comments.stdout +++ /dev/null @@ -1,17 +0,0 @@ -[ -( <no location info> = -[(Anchor CommentsTest.hs:11:1-33 UnchangedAnchor,AnnComment {ac_tok = AnnDocCommentNext " The function @foo@ does blah", ac_prior_tok = SrcSpanOneLine "./CommentsTest.hs" 9 31 33}), - -(Anchor CommentsTest.hs:(3,1)-(7,2) UnchangedAnchor,AnnComment {ac_tok = AnnBlockComment "{-\nAn opening comment\n {- with a nested one -}\n {-# nested PRAGMA #-}\n-}", ac_prior_tok = SrcSpanOneLine "./CommentsTest.hs" 2 27 32}), - -(Anchor CommentsTest.hs:1:1-31 UnchangedAnchor,AnnComment {ac_tok = AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}", ac_prior_tok = SrcSpanPoint "./CommentsTest.hs" 1 1})]) -] - -[ -( <no location info> = -[(Anchor CommentsTest.hs:11:1-33 UnchangedAnchor,AnnComment {ac_tok = AnnLineComment "-- | The function @foo@ does blah", ac_prior_tok = SrcSpanOneLine "./CommentsTest.hs" 9 31 33}), - -(Anchor CommentsTest.hs:(3,1)-(7,2) UnchangedAnchor,AnnComment {ac_tok = AnnBlockComment "{-\nAn opening comment\n {- with a nested one -}\n {-# nested PRAGMA #-}\n-}", ac_prior_tok = SrcSpanOneLine "./CommentsTest.hs" 2 27 32}), - -(Anchor CommentsTest.hs:1:1-31 UnchangedAnchor,AnnComment {ac_tok = AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}", ac_prior_tok = SrcSpanPoint "./CommentsTest.hs" 1 1})]) -] diff --git a/testsuite/tests/ghc-api/annotations/exampleTest.stdout b/testsuite/tests/ghc-api/annotations/exampleTest.stdout deleted file mode 100644 index 904b845bfd..0000000000 --- a/testsuite/tests/ghc-api/annotations/exampleTest.stdout +++ /dev/null @@ -1,88 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((AnnotationTuple.hs:1:1,AnnCloseC), [AnnotationTuple.hs:27:1]), -((AnnotationTuple.hs:1:1,AnnModule), [AnnotationTuple.hs:3:1-6]), -((AnnotationTuple.hs:1:1,AnnOpenC), [AnnotationTuple.hs:5:1]), -((AnnotationTuple.hs:1:1,AnnWhere), [AnnotationTuple.hs:3:30-34]), -((AnnotationTuple.hs:3:24-28,AnnCloseP), [AnnotationTuple.hs:3:28]), -((AnnotationTuple.hs:3:24-28,AnnOpenP), [AnnotationTuple.hs:3:24]), -((AnnotationTuple.hs:6:1-32,AnnAs), [AnnotationTuple.hs:6:28-29]), -((AnnotationTuple.hs:6:1-32,AnnImport), [AnnotationTuple.hs:6:1-6]), -((AnnotationTuple.hs:6:1-32,AnnQualified), [AnnotationTuple.hs:6:8-16]), -((AnnotationTuple.hs:6:1-32,AnnSemi), [AnnotationTuple.hs:7:1]), -((AnnotationTuple.hs:(8,1)-(11,14),AnnEqual), [AnnotationTuple.hs:8:5]), -((AnnotationTuple.hs:(8,1)-(11,14),AnnFunId), [AnnotationTuple.hs:8:1-3]), -((AnnotationTuple.hs:(8,1)-(11,14),AnnSemi), [AnnotationTuple.hs:13:1]), -((AnnotationTuple.hs:(8,7)-(11,14),AnnIn), [AnnotationTuple.hs:11:7-8]), -((AnnotationTuple.hs:(8,7)-(11,14),AnnLet), [AnnotationTuple.hs:8:7-9]), -((AnnotationTuple.hs:9:9-13,AnnEqual), [AnnotationTuple.hs:9:11]), -((AnnotationTuple.hs:9:9-13,AnnFunId), [AnnotationTuple.hs:9:9]), -((AnnotationTuple.hs:9:9-13,AnnSemi), [AnnotationTuple.hs:10:9]), -((AnnotationTuple.hs:10:9-13,AnnEqual), [AnnotationTuple.hs:10:11]), -((AnnotationTuple.hs:10:9-13,AnnFunId), [AnnotationTuple.hs:10:9]), -((AnnotationTuple.hs:11:10-14,AnnVal), [AnnotationTuple.hs:11:12]), -((AnnotationTuple.hs:14:1-72,AnnEqual), [AnnotationTuple.hs:14:5]), -((AnnotationTuple.hs:14:1-72,AnnFunId), [AnnotationTuple.hs:14:1-3]), -((AnnotationTuple.hs:14:1-72,AnnSemi), [AnnotationTuple.hs:15:1]), -((AnnotationTuple.hs:14:7-72,AnnVal), [AnnotationTuple.hs:14:13]), -((AnnotationTuple.hs:14:19-53,AnnCloseP), [AnnotationTuple.hs:14:53]), -((AnnotationTuple.hs:14:19-53,AnnOpenP), [AnnotationTuple.hs:14:19]), -((AnnotationTuple.hs:14:20,AnnComma), [AnnotationTuple.hs:14:21]), -((AnnotationTuple.hs:14:23-29,AnnComma), [AnnotationTuple.hs:14:33]), -((AnnotationTuple.hs:14:35-37,AnnComma), [AnnotationTuple.hs:14:38]), -((AnnotationTuple.hs:14:39,AnnComma), [AnnotationTuple.hs:14:39]), -((AnnotationTuple.hs:14:41-52,AnnCloseS), [AnnotationTuple.hs:14:52]), -((AnnotationTuple.hs:14:41-52,AnnOpenS), [AnnotationTuple.hs:14:41]), -((AnnotationTuple.hs:14:42,AnnComma), [AnnotationTuple.hs:14:43]), -((AnnotationTuple.hs:14:45,AnnComma), [AnnotationTuple.hs:14:46]), -((AnnotationTuple.hs:14:48,AnnComma), [AnnotationTuple.hs:14:49]), -((AnnotationTuple.hs:14:55-72,AnnCloseS), [AnnotationTuple.hs:14:72]), -((AnnotationTuple.hs:14:55-72,AnnOpenS), [AnnotationTuple.hs:14:55]), -((AnnotationTuple.hs:14:56-62,AnnComma), [AnnotationTuple.hs:14:63]), -((AnnotationTuple.hs:14:61-62,AnnCloseP), [AnnotationTuple.hs:14:62]), -((AnnotationTuple.hs:14:61-62,AnnOpenP), [AnnotationTuple.hs:14:61]), -((AnnotationTuple.hs:16:1-41,AnnEqual), [AnnotationTuple.hs:16:5]), -((AnnotationTuple.hs:16:1-41,AnnFunId), [AnnotationTuple.hs:16:1-3]), -((AnnotationTuple.hs:16:1-41,AnnSemi), [AnnotationTuple.hs:17:1]), -((AnnotationTuple.hs:16:7-27,AnnCloseP), [AnnotationTuple.hs:16:27]), -((AnnotationTuple.hs:16:7-27,AnnOpenP), [AnnotationTuple.hs:16:7]), -((AnnotationTuple.hs:16:8,AnnComma), [AnnotationTuple.hs:16:9]), -((AnnotationTuple.hs:16:11-17,AnnComma), [AnnotationTuple.hs:16:18]), -((AnnotationTuple.hs:16:20-22,AnnComma), [AnnotationTuple.hs:16:23]), -((AnnotationTuple.hs:16:24,AnnComma), [AnnotationTuple.hs:16:24]), -((AnnotationTuple.hs:16:25,AnnComma), [AnnotationTuple.hs:16:25]), -((AnnotationTuple.hs:16:26,AnnComma), [AnnotationTuple.hs:16:26]), -((AnnotationTuple.hs:16:33-41,AnnCloseP), [AnnotationTuple.hs:16:41]), -((AnnotationTuple.hs:16:33-41,AnnOpenP), [AnnotationTuple.hs:16:33]), -((AnnotationTuple.hs:16:39-40,AnnCloseP), [AnnotationTuple.hs:16:40]), -((AnnotationTuple.hs:16:39-40,AnnOpenP), [AnnotationTuple.hs:16:39]), -((AnnotationTuple.hs:18:1-28,AnnData), [AnnotationTuple.hs:18:1-4]), -((AnnotationTuple.hs:18:1-28,AnnDcolon), [AnnotationTuple.hs:18:20-21]), -((AnnotationTuple.hs:18:1-28,AnnFamily), [AnnotationTuple.hs:18:6-11]), -((AnnotationTuple.hs:18:1-28,AnnSemi), [AnnotationTuple.hs:19:1]), -((AnnotationTuple.hs:18:23,AnnRarrow), [AnnotationTuple.hs:18:25-26]), -((AnnotationTuple.hs:18:23-28,AnnRarrow), [AnnotationTuple.hs:18:25-26]), -((AnnotationTuple.hs:(20,1)-(24,14),AnnFunId), [AnnotationTuple.hs:20:1-5]), -((AnnotationTuple.hs:(20,1)-(24,14),AnnSemi), [AnnotationTuple.hs:25:1]), -((AnnotationTuple.hs:(21,7)-(24,14),AnnEqual), [AnnotationTuple.hs:24:7]), -((AnnotationTuple.hs:(21,7)-(24,14),AnnVbar), [AnnotationTuple.hs:21:7]), -((AnnotationTuple.hs:21:9-24,AnnComma), [AnnotationTuple.hs:22:7]), -((AnnotationTuple.hs:21:9-24,AnnLarrow), [AnnotationTuple.hs:21:16-17]), -((AnnotationTuple.hs:22:9-25,AnnComma), [AnnotationTuple.hs:23:7]), -((AnnotationTuple.hs:22:9-25,AnnLarrow), [AnnotationTuple.hs:22:16-17]), -((AnnotationTuple.hs:23:9-24,AnnLarrow), [AnnotationTuple.hs:23:16-17]), -((AnnotationTuple.hs:26:1-10,AnnDcolon), [AnnotationTuple.hs:26:5-6]), -((AnnotationTuple.hs:26:1-14,AnnEqual), [AnnotationTuple.hs:26:12]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "AnnotationTuple.hs" 32 1 diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs deleted file mode 100644 index b07b00a2ce..0000000000 --- a/testsuite/tests/ghc-api/annotations/stringSource.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List (intercalate) -import System.IO -import GHC -import GHC.Types.Basic -import GHC.Types.SourceText -import GHC.Unit.Module.Warnings -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Data.FastString -import GHC.Types.ForeignCall -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Hs.Decls -import GHC.Data.Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName - -testOneFile libdir fileName = do - p <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - return p - - let tupArgs = gq (pm_parsed_source p) - - putStrLn (pp tupArgs) - -- putStrLn (intercalate "\n" [showAnns anns]) - - where - gq ast = everything (++) ([] `mkQ` doWarningTxt - `extQ` doImportDecl - `extQ` doCType - `extQ` doRuleDecl - `extQ` doCCallTarget - `extQ` doHsExpr - ) ast - - doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])] - doWarningTxt ((WarningTxt _ ss)) = [("w",map conv ss)] - doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)] - - doImportDecl :: ImportDecl GhcPs - -> [(String,[Located (SourceText,FastString)])] - doImportDecl (ImportDecl _ _ _ Nothing _ _ _ _ _ _) = [] - doImportDecl (ImportDecl _ _ _ (Just ss) _ _ _ _ _ _) - = [("i",[conv (noLoc ss)])] - - doCType :: CType -> [(String,[Located (SourceText,FastString)])] - doCType (CType src (Just (Header hs hf)) c) - = [("c",[noLoc (hs,hf),noLoc c])] - doCType (CType src Nothing c) = [("c",[noLoc c])] - - doRuleDecl :: RuleDecl GhcPs - -> [(String,[Located (SourceText,FastString)])] - doRuleDecl (HsRule _ ss _ _ _ _ _) = [("r",[ss])] - - doCCallTarget :: CCallTarget - -> [(String,[Located (SourceText,FastString)])] - doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] - - doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])] - doHsExpr (HsPragE _ prag _) = doPragE prag - doHsExpr _ = [] - - doPragE :: HsPragE GhcPs -> [(String,[Located (SourceText,FastString)])] - doPragE (HsPragSCC _ src ss) = [("sc",[conv (noLoc ss)])] - - conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPprUnsafe a - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - --- | Extend a generic query by a type-specific case -extQ :: ( Typeable a - , Typeable b - ) - => (a -> q) - -> (b -> q) - -> a - -> q -extQ f g a = maybe (f a) g (cast a) - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs deleted file mode 100644 index 0e702769c2..0000000000 --- a/testsuite/tests/ghc-api/annotations/t11430.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data hiding (Fixity) -import Data.List (intercalate) -import System.IO -import GHC -import GHC.Types.Basic -import GHC.Types.SourceText -import GHC.Types.Fixity -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Data.FastString -import GHC.Types.ForeignCall -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Hs.Decls -import GHC.Data.Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName - -testOneFile libdir fileName = do - p <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - return p - - let tupArgs = gq (pm_parsed_source p) - - putStrLn (intercalate "\n" $ map show tupArgs) - -- putStrLn (pp tupArgs) - -- putStrLn (intercalate "\n" [showAnns anns]) - - where - gq ast = everything (++) ([] `mkQ` doFixity - `extQ` doRuleDecl - `extQ` doHsExpr - `extQ` doInline - ) ast - - doFixity :: Fixity -> [(String,[String])] - doFixity (Fixity (SourceText ss) _ _) = [("f",[ss])] - - doRuleDecl :: RuleDecl GhcPs - -> [(String,[String])] - doRuleDecl (HsRule _ _ (ActiveBefore (SourceText ss) _) _ _ _ _) - = [("rb",[ss])] - doRuleDecl (HsRule _ _ (ActiveAfter (SourceText ss) _) _ _ _ _) - = [("ra",[ss])] - doRuleDecl (HsRule _ _ _ _ _ _ _) = [] - - doHsExpr :: HsExpr GhcPs -> [(String,[String])] - doHsExpr _ = [] - - doInline (InlinePragma _ _ _ (ActiveBefore (SourceText ss) _) _) - = [("ib",[ss])] - doInline (InlinePragma _ _ _ (ActiveAfter (SourceText ss) _) _) - = [("ia",[ss])] - doInline (InlinePragma _ _ _ _ _ ) = [] - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPprUnsafe a - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - --- | Extend a generic query by a type-specific case -extQ :: ( Typeable a - , Typeable b - ) - => (a -> q) - -> (b -> q) - -> a - -> q -extQ f g a = maybe (f a) g (cast a) - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/testsuite/tests/ghc-api/annotations/CommentsTest.hs b/testsuite/tests/printer/CommentsTest.hs index c6cf79c5da..c6cf79c5da 100644 --- a/testsuite/tests/ghc-api/annotations/CommentsTest.hs +++ b/testsuite/tests/printer/CommentsTest.hs diff --git a/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.hs b/testsuite/tests/printer/InTreeAnnotations1.hs index c454b0a237..c454b0a237 100644 --- a/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.hs +++ b/testsuite/tests/printer/InTreeAnnotations1.hs diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index 6e7b5bcd10..6be7545752 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -547,3 +547,13 @@ PprRecordDotSyntax4: PprRecordDotSyntaxA: $(CHECK_PPR) $(LIBDIR) PprRecordDotSyntaxA.hs $(CHECK_EXACT) $(LIBDIR) PprRecordDotSyntaxA.hs + +.PHONY: CommentsTest +CommentsTest: + $(CHECK_PPR) $(LIBDIR) CommentsTest.hs + $(CHECK_EXACT) $(LIBDIR) CommentsTest.hs + +.PHONY: InTreeAnnotations1 +InTreeAnnotations1: + $(CHECK_PPR) $(LIBDIR) InTreeAnnotations1.hs + $(CHECK_EXACT) $(LIBDIR) InTreeAnnotations1.hs diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index 3799b1d0ea..5c0e3fbdfa 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -121,3 +121,5 @@ test('PprRecordDotSyntax2', ignore_stderr, makefile_test, ['PprRecordDotSyntax2' test('PprRecordDotSyntax3', ignore_stderr, makefile_test, ['PprRecordDotSyntax3']) test('PprRecordDotSyntax4', ignore_stderr, makefile_test, ['PprRecordDotSyntax4']) test('PprRecordDotSyntaxA', ignore_stderr, makefile_test, ['PprRecordDotSyntaxA']) +test('CommentsTest', ignore_stderr, makefile_test, ['CommentsTest']) +test('InTreeAnnotations1', ignore_stderr, makefile_test, ['InTreeAnnotations1']) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 8f4f89e265..80ef0eb19c 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -50,17 +50,17 @@ import Types -- --------------------------------------------------------------------- -exactPrint :: ExactPrint ast => Located ast -> ApiAnns -> String -exactPrint ast anns = runIdentity (runEP anns stringOptions (markAnnotated ast)) +exactPrint :: ExactPrint ast => Located ast -> String +exactPrint ast = runIdentity (runEP stringOptions (markAnnotated ast)) type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a type EPP a = EP String Identity a -runEP :: ApiAnns -> PrintOptions Identity String +runEP :: PrintOptions Identity String -> Annotated () -> Identity String -runEP anns epReader action = +runEP epReader action = fmap (output . snd) . - (\next -> execRWST next epReader (defaultEPState anns)) + (\next -> execRWST next epReader defaultEPState) . xx $ action xx :: Annotated () -> EP String Identity () @@ -69,10 +69,9 @@ xx = id -- --------------------------------------------------------------------- -defaultEPState :: ApiAnns -> EPState -defaultEPState as = EPState +defaultEPState :: EPState +defaultEPState = EPState { epPos = (1,1) - , epApiAnns = as , dLHS = 1 , pMarkLayout = False , pLHS = 1 @@ -80,7 +79,7 @@ defaultEPState as = EPState , dPriorEndPosition = (1,1) , uAnchorSpan = badRealSrcSpan , uExtraDP = Nothing - , epComments = rogueComments as + , epComments = [] } @@ -130,9 +129,7 @@ instance Monoid w => Monoid (EPWriter w) where mempty = EPWriter mempty data EPState = EPState - { epApiAnns :: !ApiAnns - - , uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST + { uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST -- reference frame, from -- Annotation , uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a @@ -3628,7 +3625,9 @@ instance ExactPrint (Pat GhcPs) where -- filtered. let pun_RDR = "pun-right-hand-side" when (showPprUnsafe n /= pun_RDR) $ markAnnotated n - -- | LazyPat an pat) + exact (LazyPat an pat) = do + markApiAnn an AnnTilde + markAnnotated pat exact (AsPat an n pat) = do markAnnotated n markApiAnn an AnnAt @@ -3638,7 +3637,10 @@ instance ExactPrint (Pat GhcPs) where markAnnotated pat markAnnKw an ap_close AnnCloseP - -- | BangPat an pat) + exact (BangPat an pat) = do + markApiAnn an AnnBang + markAnnotated pat + exact (ListPat an pats) = markAnnList an (markAnnotated pats) exact (TuplePat an pats boxity) = do diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index 23fb0a825e..48b9da62c4 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -36,47 +36,48 @@ _tt :: IO () -- _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" - -- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" changeRenameCase1 - -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" changeLayoutLet2 - -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet3.hs" changeLayoutLet3 - -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet4.hs" changeLayoutLet3 - -- "../../testsuite/tests/ghc-api/exactprint/Rename1.hs" changeRename1 - -- "../../testsuite/tests/ghc-api/exactprint/Rename2.hs" changeRename2 - -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn1.hs" changeLayoutIn1 - -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3.hs" changeLayoutIn3 - -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3a.hs" changeLayoutIn3 - -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3b.hs" changeLayoutIn3 - -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn4.hs" changeLayoutIn4 - -- "../../testsuite/tests/ghc-api/exactprint/LocToName.hs" changeLocToName - -- "../../testsuite/tests/ghc-api/exactprint/LetIn1.hs" changeLetIn1 - -- "../../testsuite/tests/ghc-api/exactprint/WhereIn4.hs" changeWhereIn4 - -- "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" changeAddDecl1 - -- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" changeAddDecl2 - -- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" changeAddDecl3 - -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" changeLocalDecls - -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" changeLocalDecls2 - -- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" changeWhereIn3a - -- "../../testsuite/tests/ghc-api/exactprint/WhereIn3b.hs" changeWhereIn3b - -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl1.hs" addLocaLDecl1 - -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl2.hs" addLocaLDecl2 - -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl3.hs" addLocaLDecl3 - -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" addLocaLDecl4 - -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" addLocaLDecl5 - -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6) - -- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" rmDecl1 - -- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" rmDecl2 - -- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" rmDecl3 - -- "../../testsuite/tests/ghc-api/exactprint/RmDecl4.hs" rmDecl4 - -- "../../testsuite/tests/ghc-api/exactprint/RmDecl5.hs" rmDecl5 - -- "../../testsuite/tests/ghc-api/exactprint/RmDecl6.hs" rmDecl6 - -- "../../testsuite/tests/ghc-api/exactprint/RmDecl7.hs" rmDecl7 - -- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig1.hs" rmTypeSig1 - -- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig2.hs" rmTypeSig2 - -- "../../testsuite/tests/ghc-api/exactprint/AddHiding1.hs" addHiding1 - -- "../../testsuite/tests/ghc-api/exactprint/AddHiding2.hs" addHiding2 + + -- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1) + -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2) + -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet3.hs" (Just changeLayoutLet3) + -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet4.hs" (Just changeLayoutLet3) + -- "../../testsuite/tests/ghc-api/exactprint/Rename1.hs" (Just changeRename1) + -- "../../testsuite/tests/ghc-api/exactprint/Rename2.hs" (Just changeRename2) + -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn1.hs" (Just changeLayoutIn1) + -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3.hs" (Just changeLayoutIn3) + -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3a.hs" (Just changeLayoutIn3) + -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3b.hs" (Just changeLayoutIn3) + -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn4.hs" (Just changeLayoutIn4) + -- "../../testsuite/tests/ghc-api/exactprint/LocToName.hs" (Just changeLocToName) + -- "../../testsuite/tests/ghc-api/exactprint/LetIn1.hs" (Just changeLetIn1) + -- "../../testsuite/tests/ghc-api/exactprint/WhereIn4.hs" (Just changeWhereIn4) + -- "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1) + -- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2) + -- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" (Just changeAddDecl3) + -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" (Just changeLocalDecls) + -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2) + -- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" (Just changeWhereIn3a) + -- "../../testsuite/tests/ghc-api/exactprint/WhereIn3b.hs" (Just changeWhereIn3b) + -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl1.hs" (Just addLocaLDecl1) + -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl2.hs" (Just addLocaLDecl2) + -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl3.hs" (Just addLocaLDecl3) + -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4) + -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5) + -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just (Just addLocaLDecl6)) + -- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1) + -- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2) + -- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3) + -- "../../testsuite/tests/ghc-api/exactprint/RmDecl4.hs" (Just rmDecl4) + -- "../../testsuite/tests/ghc-api/exactprint/RmDecl5.hs" (Just rmDecl5) + -- "../../testsuite/tests/ghc-api/exactprint/RmDecl6.hs" (Just rmDecl6) + -- "../../testsuite/tests/ghc-api/exactprint/RmDecl7.hs" (Just rmDecl7) + -- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig1.hs" (Just rmTypeSig1) + -- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig2.hs" (Just rmTypeSig2) + -- "../../testsuite/tests/ghc-api/exactprint/AddHiding1.hs" (Just addHiding1) + -- "../../testsuite/tests/ghc-api/exactprint/AddHiding2.hs" (Just addHiding2) -- "../../testsuite/tests/printer/Ppr001.hs" Nothing - "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs" Nothing + -- "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs" Nothing -- "../../testsuite/tests/hiefile/should_compile/Constructors.hs" Nothing -- "../../testsuite/tests/hiefile/should_compile/Scopes.hs" Nothing -- "../../testsuite/tests/hiefile/should_compile/hie008.hs" Nothing @@ -171,6 +172,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin -- "../../testsuite/tests/printer/Test16230.hs" Nothing -- "../../testsuite/tests/printer/Test16236.hs" Nothing -- "../../testsuite/tests/printer/Test17519.hs" Nothing + "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -232,8 +234,8 @@ changers = usage :: String usage = unlines - [ "usage: check-ppr (libdir) (file)" - , " check-ppr (libdir) (changer) (file)" + [ "usage: check-exact (libdir) (file)" + , " check-exact (libdir) (file) (changer)" , "" , "where libdir is the GHC library directory (e.g. the output of" , "ghc --print-libdir), file is the file to parse" @@ -246,13 +248,14 @@ main = do args <- getArgs case args of [libdir,fileName] -> testOneFile changers libdir fileName Nothing - [libdir,fileName,changerStr] -> case lookup changerStr changers of - Just doChange -> testOneFile changers libdir fileName (Just doChange) - Nothing -> do - putStrLn $ "exactprint: could not find changer for [" ++ changerStr ++ "]" - putStrLn $ "valid changers are:\n" ++ unlines (map fst changers) - putStrLn $ "(see utils/check-exact/Main.hs)" - exitFailure + [libdir,fileName,changerStr] -> do + case lookup changerStr changers of + Just doChange -> testOneFile changers libdir fileName (Just doChange) + Nothing -> do + putStrLn $ "exactprint: could not find changer for [" ++ changerStr ++ "]" + putStrLn $ "valid changers are:\n" ++ unlines (map fst changers) + putStrLn $ "(see utils/check-exact/Main.hs)" + exitFailure _ -> putStrLn usage deriving instance Data Token @@ -266,11 +269,10 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do (p,_toks) <- parseOneFile libdir fileName - -- putStrLn $ "\n\ngot p" ++ showAst (take 4 $ reverse toks) + -- putStrLn $ "\n\ngot p" ++ showAst (take 4 $ reverse _toks) let origAst = ppAst (pm_parsed_source p) - anns' = pm_annotations p - pped = exactPrint (pm_parsed_source p) anns' + pped = exactPrint (pm_parsed_source p) newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName newFileChanged = dropExtension fileName <.> "changed" <.> takeExtension fileName @@ -284,7 +286,7 @@ testOneFile _ libdir fileName mchanger = do (changedSourceOk, expectedSource, changedSource) <- case mchanger of Just changer -> do - (pped', ast') <- exactprintWithChange libdir changer (pm_parsed_source p) anns' + (pped', ast') <- exactprintWithChange libdir changer (pm_parsed_source p) writeBinFile changedAstFile (ppAst ast') writeBinFile newFileChanged pped' @@ -299,9 +301,8 @@ testOneFile _ libdir fileName mchanger = do newAstStr = ppAst (pm_parsed_source p') writeBinFile newAstFile newAstStr + let origAstOk = origAst == newAstStr - let - origAstOk = origAst == newAstStr if origAstOk && changedSourceOk then do exitSuccess @@ -350,63 +351,47 @@ parseOneFile libdir fileName = do toks <- getTokenStream (ms_mod modSum) return (pm, toks) - -- getTokenStream :: GhcMonad m => Module -> m [Located Token] - --- getPragmas :: ApiAnns -> String --- getPragmas anns' = pragmaStr --- where --- tokComment (L _ (AnnBlockComment s)) = s --- tokComment (L _ (AnnLineComment s)) = s --- tokComment _ = "" - --- comments' = map tokComment $ sortRealLocated $ apiAnnRogueComments anns' --- pragmas = filter (\c -> isPrefixOf "{-#" c ) comments' --- pragmaStr = intercalate "\n" pragmas - --- pp :: (Outputable a) => a -> String --- pp a = showPpr unsafeGlobalDynFlags a -- --------------------------------------------------------------------- -exactprintWithChange :: FilePath -> Changer -> ParsedSource -> ApiAnns -> IO (String, ParsedSource) -exactprintWithChange libdir f p apiAnns = do - debugM $ "exactprintWithChange:apiAnns=" ++ showGhc (apiAnnRogueComments apiAnns) - (apiAnns',p') <- f libdir apiAnns p - return (exactPrint p' apiAnns', p') +exactprintWithChange :: FilePath -> Changer -> ParsedSource -> IO (String, ParsedSource) +exactprintWithChange libdir f p = do + p' <- f libdir p + return (exactPrint p', p') -- First param is libdir -type Changer = FilePath -> (ApiAnns -> ParsedSource -> IO (ApiAnns,ParsedSource)) +type Changer = FilePath -> (ParsedSource -> IO ParsedSource) noChange :: Changer -noChange _libdir ans parsed = return (ans,parsed) +noChange _libdir parsed = return parsed changeRenameCase1 :: Changer -changeRenameCase1 _libdir ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed) +changeRenameCase1 _libdir parsed = return (rename "bazLonger" [((3,15),(3,18))] parsed) changeLayoutLet2 :: Changer -changeLayoutLet2 _libdir ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed) +changeLayoutLet2 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed) changeLayoutLet3 :: Changer -changeLayoutLet3 _libdir ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed) +changeLayoutLet3 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed) changeLayoutIn1 :: Changer -changeLayoutIn1 _libdir ans parsed = return (ans,rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed) +changeLayoutIn1 _libdir parsed = return (rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed) changeLayoutIn3 :: Changer -changeLayoutIn3 _libdir ans parsed = return (ans,rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed) +changeLayoutIn3 _libdir parsed = return (rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed) changeLayoutIn4 :: Changer -changeLayoutIn4 _libdir ans parsed = return (ans,rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed) +changeLayoutIn4 _libdir parsed = return (rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed) changeLocToName :: Changer -changeLocToName _libdir ans parsed = return (ans,rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed) +changeLocToName _libdir parsed = return (rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed) changeRename1 :: Changer -changeRename1 _libdir ans parsed = return (ans,rename "bar2" [((3,1),(3,4))] parsed) +changeRename1 _libdir parsed = return (rename "bar2" [((3,1),(3,4))] parsed) changeRename2 :: Changer -changeRename2 _libdir ans parsed = return (ans,rename "joe" [((2,1),(2,5))] parsed) +changeRename2 _libdir parsed = return (rename "joe" [((2,1),(2,5))] parsed) rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a rename newNameStr spans' a @@ -425,8 +410,8 @@ rename newNameStr spans' a -- --------------------------------------------------------------------- changeWhereIn4 :: Changer -changeWhereIn4 _libdir ans parsed - = return (ans,everywhere (mkT replace) parsed) +changeWhereIn4 _libdir parsed + = return (everywhere (mkT replace) parsed) where replace :: LocatedN RdrName -> LocatedN RdrName replace (L ln _n) @@ -436,8 +421,8 @@ changeWhereIn4 _libdir ans parsed -- --------------------------------------------------------------------- changeLetIn1 :: Changer -changeLetIn1 _libdir ans parsed - = return (ans,everywhere (mkT replace) parsed) +changeLetIn1 _libdir parsed + = return (everywhere (mkT replace) parsed) where replace :: HsExpr GhcPs -> HsExpr GhcPs replace (HsLet (ApiAnn anc (AnnsLet l _i) cs) localDecls expr) @@ -448,27 +433,29 @@ changeLetIn1 _libdir ans parsed (L (SrcSpanAnn _ le) e) = expr a = (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan le) (MovedAnchor (DP 0 1))) mempty noCom) le) expr' = L a e - in (HsLet (ApiAnn anc (AnnsLet l (AD (DP 1 0))) cs) (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') + in (HsLet (ApiAnn anc (AnnsLet l (AD (DP 1 0))) cs) + (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') replace x = x + -- --------------------------------------------------------------------- -- | Add a declaration to AddDecl changeAddDecl1 :: Changer -changeAddDecl1 libdir ans top = do - Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") +changeAddDecl1 libdir top = do + Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") let decl' = setEntryDP' decl (DP 2 0) let (p',(_,_),_) = runTransform mempty doAddDecl doAddDecl = everywhereM (mkM replaceTopLevelDecls) top replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource replaceTopLevelDecls m = insertAtStart m decl' - return (ans,p') + return p' -- --------------------------------------------------------------------- changeAddDecl2 :: Changer -changeAddDecl2 libdir ans top = do - Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") +changeAddDecl2 libdir top = do + Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") let decl' = setEntryDP' decl (DP 2 0) let top' = anchorEof top @@ -476,12 +463,13 @@ changeAddDecl2 libdir ans top = do doAddDecl = everywhereM (mkM replaceTopLevelDecls) top' replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource replaceTopLevelDecls m = insertAtEnd m decl' - return (ans,p') + return p' -- --------------------------------------------------------------------- + changeAddDecl3 :: Changer -changeAddDecl3 libdir ans top = do - Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") +changeAddDecl3 libdir top = do + Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") let decl' = setEntryDP' decl (DP 2 0) let (p',(_,_),_) = runTransform mempty doAddDecl @@ -491,15 +479,15 @@ changeAddDecl3 libdir ans top = do l2' = setEntryDP' l2 (DP 2 0) replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource replaceTopLevelDecls m = insertAt f m decl' - return (ans,p') + return p' -- --------------------------------------------------------------------- -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer -changeLocalDecls libdir ans (L l p) = do - Right (_, s@(L ls (SigD _ sig))) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") - Right (_, d@(L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") +changeLocalDecls libdir (L l p) = do + Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let decl' = setEntryDP' (L ld decl) (DP 1 0) let sig' = setEntryDP' (L ls sig) (DP 0 0) let (p',(_,_),_w) = runTransform mempty doAddLocal @@ -521,16 +509,16 @@ changeLocalDecls libdir ans (L l p) = do (sig':os':oldSigs))) return (L lm (Match an mln pats (GRHSs noExtField rhs binds'))) replaceLocalBinds x = return x - return (ans,L l p') + return (L l p') -- --------------------------------------------------------------------- -- | Add a local declaration with signature to LocalDecl, where there was no -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer -changeLocalDecls2 libdir ans (L l p) = do - Right (_, d@(L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - Right (_, s@(L ls (SigD _ sig))) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") +changeLocalDecls2 libdir (L l p) = do + Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let decl' = setEntryDP' (L ld decl) (DP 1 0) let sig' = setEntryDP' (L ls sig) (DP 0 2) let (p',(_,_),_w) = runTransform mempty doAddLocal @@ -551,25 +539,25 @@ changeLocalDecls2 libdir ans (L l p) = do [sig'])) return (L lm (Match ma mln pats (GRHSs noExtField rhs binds))) replaceLocalBinds x = return x - return (ans,L l p') + return (L l p') -- --------------------------------------------------------------------- -- | Check that balanceCommentsList is idempotent changeWhereIn3a :: Changer -changeWhereIn3a _libdir ans (L l p) = do +changeWhereIn3a _libdir (L l p) = do let decls0 = hsmodDecls p (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0) (_de0:_:de1:_d2:_) = decls debugM $ unlines w debugM $ "changeWhereIn3a:de1:" ++ showAst de1 let p2 = p { hsmodDecls = decls} - return (ans,L l p2) + return (L l p2) -- --------------------------------------------------------------------- changeWhereIn3b :: Changer -changeWhereIn3b _libdir ans (L l p) = do +changeWhereIn3b _libdir (L l p) = do let decls0 = hsmodDecls p (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0) (de0:_:de1:d2:_) = decls @@ -580,13 +568,13 @@ changeWhereIn3b _libdir ans (L l p) = do debugM $ unlines w debugM $ "changeWhereIn3b:de1':" ++ showAst de1' let p2 = p { hsmodDecls = decls'} - return (ans,L l p2) + return (L l p2) -- --------------------------------------------------------------------- addLocaLDecl1 :: Changer -addLocaLDecl1 libdir ans lp = do - Right (_, (L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") +addLocaLDecl1 libdir lp = do + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let decl' = setEntryDP' (L ld decl) (DP 1 4) doAddLocal = do (de1:d2:d3:_) <- hsDecls lp @@ -597,13 +585,13 @@ addLocaLDecl1 libdir ans lp = do (lp',(_,_),w) <- runTransformT mempty doAddLocal debugM $ "addLocaLDecl1:" ++ intercalate "\n" w - return (ans,lp') + return lp' -- --------------------------------------------------------------------- addLocaLDecl2 :: Changer -addLocaLDecl2 libdir ans lp = do - Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") +addLocaLDecl2 libdir lp = do + Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let doAddLocal = do (de1:d2:_) <- hsDecls lp @@ -618,14 +606,13 @@ addLocaLDecl2 libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doAddLocal debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- addLocaLDecl3 :: Changer -addLocaLDecl3 libdir ans lp = do - Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - -- Right (_, newDecl@(L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "jj = 2") +addLocaLDecl3 libdir lp = do + Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let doAddLocal = do (de1:d2:_) <- hsDecls lp @@ -639,15 +626,14 @@ addLocaLDecl3 libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doAddLocal debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- addLocaLDecl4 :: Changer -addLocaLDecl4 libdir ans lp = do - Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - Right (_, newSig) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") - -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp +addLocaLDecl4 libdir lp = do + Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let doAddLocal = do (parent:ds) <- hsDecls lp @@ -662,13 +648,13 @@ addLocaLDecl4 libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doAddLocal debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- addLocaLDecl5 :: Changer -addLocaLDecl5 _libdir ans lp = do +addLocaLDecl5 _libdir lp = do let doAddLocal = do decls <- hsDecls lp @@ -683,13 +669,13 @@ addLocaLDecl5 _libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doAddLocal debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- addLocaLDecl6 :: Changer -addLocaLDecl6 libdir ans lp = do - Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") +addLocaLDecl6 libdir lp = do + Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") let newDecl' = setEntryDP' newDecl (DP 1 4) doAddLocal = do @@ -706,12 +692,12 @@ addLocaLDecl6 libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doAddLocal debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmDecl1 :: Changer -rmDecl1 _libdir ans lp = do +rmDecl1 _libdir lp = do let doRmDecl = do tlDecs0 <- hsDecls lp tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0 @@ -721,12 +707,12 @@ rmDecl1 _libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmDecl2 :: Changer -rmDecl2 _libdir ans lp = do +rmDecl2 _libdir lp = do let doRmDecl = do let @@ -742,12 +728,12 @@ rmDecl2 _libdir ans lp = do let (lp',(_,_),_w) = runTransform mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmDecl3 :: Changer -rmDecl3 _libdir ans lp = do +rmDecl3 _libdir lp = do let doRmDecl = do [de1,d2] <- hsDecls lp @@ -760,12 +746,12 @@ rmDecl3 _libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmDecl4 :: Changer -rmDecl4 _libdir ans lp = do +rmDecl4 _libdir lp = do let doRmDecl = do [de1] <- hsDecls lp @@ -780,12 +766,12 @@ rmDecl4 _libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmDecl5 :: Changer -rmDecl5 _libdir ans lp = do +rmDecl5 _libdir lp = do let doRmDecl = do let @@ -802,12 +788,12 @@ rmDecl5 _libdir ans lp = do let (lp',(_,_),_w) = runTransform mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmDecl6 :: Changer -rmDecl6 _libdir ans lp = do +rmDecl6 _libdir lp = do let doRmDecl = do [de1] <- hsDecls lp @@ -822,12 +808,12 @@ rmDecl6 _libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmDecl7 :: Changer -rmDecl7 _libdir ans lp = do +rmDecl7 _libdir lp = do let doRmDecl = do tlDecs <- hsDecls lp @@ -839,12 +825,12 @@ rmDecl7 _libdir ans lp = do (lp',(_,_),_w) <- runTransformT mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmTypeSig1 :: Changer -rmTypeSig1 _libdir ans lp = do +rmTypeSig1 _libdir lp = do let doRmDecl = do tlDecs <- hsDecls lp let (s0:de1:d2) = tlDecs @@ -856,12 +842,12 @@ rmTypeSig1 _libdir ans lp = do let (lp',(_,_),_w) = runTransform mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- rmTypeSig2 :: Changer -rmTypeSig2 _libdir ans lp = do +rmTypeSig2 _libdir lp = do let doRmDecl = do tlDecs <- hsDecls lp let [de1] = tlDecs @@ -873,12 +859,12 @@ rmTypeSig2 _libdir ans lp = do let (lp',(_,_),_w) = runTransform mempty doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- addHiding1 :: Changer -addHiding1 _libdir ans (L l p) = do +addHiding1 _libdir (L l p) = do let doTransform = do l0 <- uniqueSrcSpanT l1 <- uniqueSrcSpanT @@ -902,12 +888,12 @@ addHiding1 _libdir ans (L l p) = do let (lp',(_ans',_),_w) = runTransform mempty doTransform debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- addHiding2 :: Changer -addHiding2 _libdir ans (L l p) = do +addHiding2 _libdir (L l p) = do let doTransform = do l1 <- uniqueSrcSpanT l2 <- uniqueSrcSpanT @@ -933,7 +919,7 @@ addHiding2 _libdir ans (L l p) = do let (lp',(_ans',_),_w) = runTransform mempty doTransform debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" - return (ans,lp') + return lp' -- --------------------------------------------------------------------- diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs index 403ee3e55d..d4b1756ef9 100644 --- a/utils/check-exact/Parsers.hs +++ b/utils/check-exact/Parsers.hs @@ -88,7 +88,7 @@ parseWith :: GHC.DynFlags parseWith dflags fileName parser s = case runParser parser dflags fileName s of GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) - GHC.POk (mkApiAnns -> apianns) pmod -> Right (apianns, pmod) + GHC.POk _ pmod -> Right pmod parseWithECP :: (GHC.DisambECP w) @@ -102,7 +102,7 @@ parseWithECP dflags fileName parser s = -- case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) - GHC.POk (mkApiAnns -> apianns) pmod -> Right (apianns, pmod) + GHC.POk _ pmod -> Right pmod -- --------------------------------------------------------------------- @@ -134,7 +134,7 @@ parseFile = runParser GHC.parseModule -- --------------------------------------------------------------------- -type ParseResult a = Either GHC.ErrorMessages (GHC.ApiAnns, a) +type ParseResult a = Either GHC.ErrorMessages a type Parser a = GHC.DynFlags -> FilePath -> String -> ParseResult a @@ -193,7 +193,7 @@ parseModuleFromStringInternal dflags fileName str = let (str1, lp) = stripLinePragmas str res = case runParser GHC.parseModule dflags fileName str1 of GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) - GHC.POk x pmod -> Right (mkApiAnns x, lp, dflags, pmod) + GHC.POk _ pmod -> Right (lp, dflags, pmod) in postParseTransform res parseModuleWithOptions :: FilePath -- ^ GHC libdir @@ -225,7 +225,7 @@ parseModuleApiAnnsWithCpp -> IO ( Either GHC.ErrorMessages - (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + ([Comment], GHC.DynFlags, GHC.ParsedSource) ) parseModuleApiAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do dflags <- initDynFlags file @@ -247,7 +247,7 @@ parseModuleApiAnnsWithCppInternal -> m ( Either GHC.ErrorMessages - (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + ([Comment], GHC.DynFlags, GHC.ParsedSource) ) parseModuleApiAnnsWithCppInternal cppOptions dflags file = do let useCpp = GHC.xopt LangExt.Cpp dflags @@ -264,17 +264,17 @@ parseModuleApiAnnsWithCppInternal cppOptions dflags file = do return $ case parseFile dflags' file fileContents of GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) - GHC.POk (mkApiAnns -> apianns) pmod -> - Right $ (apianns, injectedComments, dflags', pmod) + GHC.POk _ pmod -> + Right $ (injectedComments, dflags', pmod) -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing. postParseTransform - :: Either a (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) - -> Either a (GHC.ApiAnns, GHC.ParsedSource) + :: Either a ([Comment], GHC.DynFlags, GHC.ParsedSource) + -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (apianns, _cs, _, m) = (apianns, m) + mkAnns (_cs, _, m) = m -- (relativiseApiAnnsWithOptions opts cs m apianns, m) -- | Internal function. Initializes DynFlags value for parsing. @@ -324,9 +324,3 @@ initDynFlagsPure fp s = do return dflags3 -- --------------------------------------------------------------------- - -mkApiAnns :: GHC.PState -> GHC.ApiAnns -mkApiAnns pstate - = GHC.ApiAnns { - GHC.apiAnnRogueComments = GHC.comment_q pstate - } diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index 23f166514f..5741bb66dd 100644 --- a/utils/check-exact/Utils.hs +++ b/utils/check-exact/Utils.hs @@ -306,24 +306,6 @@ mkKWComment kw (AD dp) comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos) comment2dp = first AnnComment - -rogueComments :: ApiAnns -> [Comment] -rogueComments as = extractRogueComments as - -- where - -- go :: Comment -> (Comment, DeltaPos) - -- go c@(Comment _str loc _mo) = (c, ss2delta (1,1) loc) - --- extractComments :: ApiAnns -> [Comment] --- extractComments anns --- -- cm has type :: Map RealSrcSpan [LAnnotationComment] --- -- = map tokComment . sortRealLocated . concat $ Map.elems (apiAnnComments anns) --- = [] - -extractRogueComments :: ApiAnns -> [Comment] -extractRogueComments anns - -- cm has type :: Map RealSrcSpan [LAnnotationComment] - = map tokComment $ sortAnchorLocated (apiAnnRogueComments anns) - sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a] sortAnchorLocated = sortBy (compare `on` (anchor . getLoc)) diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs index f537a0085c..0973d2ccfe 100644 --- a/utils/check-ppr/Main.hs +++ b/utils/check-ppr/Main.hs @@ -45,8 +45,7 @@ testOneFile libdir fileName = do $ showAstData BlankSrcSpan BlankApiAnnotations $ eraseLayoutInfo (pm_parsed_source p) pped = pragmas ++ "\n" ++ pp (pm_parsed_source p) - anns' = pm_annotations p - pragmas = getPragmas anns' + pragmas = getPragmas (pm_parsed_source p) newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName astFile = fileName <.> "ast" @@ -98,15 +97,15 @@ parseOneFile libdir fileName = do ++ show (map (ml_hs_file . ms_location) xs) parseModule modSum -getPragmas :: ApiAnns -> String -getPragmas anns' = pragmaStr +getPragmas :: Located HsModule -> String +getPragmas (L _ (HsModule { hsmodAnn = anns'})) = pragmaStr where tokComment (L _ (AnnComment (AnnBlockComment s) _)) = s tokComment (L _ (AnnComment (AnnLineComment s) _)) = s tokComment _ = "" cmp (L l1 _) (L l2 _) = compare (anchor l1) (anchor l2) - comments' = map tokComment $ sortBy cmp $ apiAnnRogueComments anns' + comments' = map tokComment $ sortBy cmp $ priorComments $ apiAnnComments anns' pragmas = filter (\c -> isPrefixOf "{-#" c ) comments' pragmaStr = intercalate "\n" pragmas |