@@ -152,23 +152,29 @@ import System.IO (hClose)
152152import UnliftIO.Temporary (withSystemTempFile )
153153import Util (OverridingBool (Never ))
154154
155-
155+ import IfaceSyn (showToHeader )
156+ import PprTyThing (pprTyThingInContext , pprTypeForUser )
156157#if MIN_VERSION_ghc(9,0,0)
157- import GHC.Parser.Annotation (ApiAnns (apiAnnComments ))
158+ import GHC.Parser.Annotation (ApiAnns (apiAnnRogueComments ))
159+ import GHC.Parser.Lexer (mkParserFlags )
160+ import GHC.Driver.Ways (hostFullWays ,
161+ wayGeneralFlags ,
162+ wayUnsetGeneralFlags )
163+ import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive ))
158164#else
159165import GhcPlugins (interpWays , updateWays ,
160166 wayGeneralFlags ,
161167 wayUnsetGeneralFlags )
162- import IfaceSyn (showToHeader )
163- import PprTyThing (pprTyThingInContext )
164168#endif
165169
166170#if MIN_VERSION_ghc(9,0,0)
167171pattern RealSrcSpanAlready :: SrcLoc. RealSrcSpan -> SrcLoc. RealSrcSpan
168172pattern RealSrcSpanAlready x = x
173+ apiAnnComments' :: SrcLoc. ApiAnns -> [SrcLoc. RealLocated AnnotationComment ]
174+ apiAnnComments' = apiAnnRogueComments
169175#else
170- apiAnnComments :: SrcLoc. ApiAnns -> Map. Map SrcSpan [SrcLoc. Located AnnotationComment ]
171- apiAnnComments = snd
176+ apiAnnComments' :: SrcLoc. ApiAnns -> [SrcLoc. Located AnnotationComment ]
177+ apiAnnComments' = concat . Map. elems . snd
172178
173179pattern RealSrcSpanAlready :: SrcLoc. RealSrcSpan -> SrcSpan
174180pattern RealSrcSpanAlready x = SrcLoc. RealSrcSpan x
@@ -190,9 +196,9 @@ codeLens st plId CodeLensParams{_textDocument} =
190196 isLHS = isLiterate fp
191197 dbg " fp" fp
192198 (ParsedModule {.. }, posMap) <- liftIO $
193- runAction " parsed " st $ useWithStale_ GetParsedModuleWithComments nfp
194- let comments = foldMap
195- ( foldMap $ \ case
199+ runAction " eval.GetParsedModuleWithComments " st $ useWithStale_ GetParsedModuleWithComments nfp
200+ let comments =
201+ foldMap ( \ case
196202 L (RealSrcSpanAlready real) bdy
197203 | unpackFS (srcSpanFile real) ==
198204 fromNormalizedFilePath nfp
@@ -210,16 +216,15 @@ codeLens st plId CodeLensParams{_textDocument} =
210216 _ -> mempty
211217 _ -> mempty
212218 )
213- $ apiAnnComments pm_annotations
219+ $ apiAnnComments' pm_annotations
214220 dbg " excluded comments" $ show $ DL. toList $
215- foldMap
216- (foldMap $ \ (L a b) ->
221+ foldMap (\ (L a b) ->
217222 case b of
218223 AnnLineComment {} -> mempty
219224 AnnBlockComment {} -> mempty
220225 _ -> DL. singleton (a, b)
221226 )
222- $ apiAnnComments pm_annotations
227+ $ apiAnnComments' pm_annotations
223228 dbg " comments" $ show comments
224229
225230 -- Extract tests from source code
@@ -546,7 +551,7 @@ evals (st, fp) df stmts = do
546551 eans <-
547552 liftIO $ try @ GhcException $
548553 parseDynamicFlagsCmdLine ndf
549- (map (L $ UnhelpfulSpan " <interactive> " ) flags)
554+ (map (L $ UnhelpfulSpan unhelpfulReason ) flags)
550555 dbg " parsed flags" $ eans
551556 <&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg)
552557 case eans of
@@ -572,7 +577,7 @@ evals (st, fp) df stmts = do
572577 Just (cmd, arg) <- parseGhciLikeCmd $ T. pack stmt =
573578 evalGhciLikeCmd cmd arg
574579 | -- A statement
575- isStmt df stmt =
580+ isStmt pf stmt =
576581 do
577582 dbg " {STMT " stmt
578583 res <- exec stmt l
@@ -582,7 +587,7 @@ evals (st, fp) df stmts = do
582587 dbg " STMT} -> " r
583588 return r
584589 | -- An import
585- isImport df stmt =
590+ isImport pf stmt =
586591 do
587592 dbg " {IMPORT " stmt
588593 _ <- addImport stmt
@@ -593,6 +598,13 @@ evals (st, fp) df stmts = do
593598 dbg " {DECL " stmt
594599 void $ runDecls stmt
595600 return Nothing
601+ #if !MIN_VERSION_ghc(9,0,0)
602+ pf = df
603+ unhelpfulReason = " <interactive>"
604+ #else
605+ pf = mkParserFlags df
606+ unhelpfulReason = UnhelpfulInteractive
607+ #endif
596608 exec stmt l =
597609 let opts = execOptions{execSourceFile = fp, execLineNumber = l}
598610 in myExecStmt stmt opts
@@ -739,20 +751,20 @@ doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
739751doKindCmd False df arg = do
740752 let input = T. strip arg
741753 (_, kind) <- typeKind False $ T. unpack input
742- let kindText = text (T. unpack input) <+> " ::" <+> ppr kind
754+ let kindText = text (T. unpack input) <+> " ::" <+> pprTypeForUser kind
743755 pure $ Just $ T. pack (showSDoc df kindText)
744756doKindCmd True df arg = do
745757 let input = T. strip arg
746758 (ty, kind) <- typeKind True $ T. unpack input
747- let kindDoc = text (T. unpack input) <+> " ::" <+> ppr kind
748- tyDoc = " =" <+> ppr ty
759+ let kindDoc = text (T. unpack input) <+> " ::" <+> pprTypeForUser kind
760+ tyDoc = " =" <+> pprTypeForUser ty
749761 pure $ Just $ T. pack (showSDoc df $ kindDoc $$ tyDoc)
750762
751763doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text )
752764doTypeCmd dflags arg = do
753765 let (emod, expr) = parseExprMode arg
754766 ty <- exprType emod $ T. unpack expr
755- let rawType = T. strip $ T. pack $ showSDoc dflags $ ppr ty
767+ let rawType = T. strip $ T. pack $ showSDoc dflags $ pprTypeForUser ty
756768 broken = T. any (\ c -> c == ' \r ' || c == ' \n ' ) rawType
757769 pure $
758770 Just $
@@ -761,7 +773,7 @@ doTypeCmd dflags arg = do
761773 T. pack $
762774 showSDoc dflags $
763775 text (T. unpack expr)
764- $$ nest 2 (" ::" <+> ppr ty)
776+ $$ nest 2 (" ::" <+> pprTypeForUser ty)
765777 else expr <> " :: " <> rawType <> " \n "
766778
767779parseExprMode :: Text -> (TcRnExprMode , T. Text )
@@ -804,13 +816,18 @@ setupDynFlagsForGHCiLike env dflags = do
804816 , ghcLink = LinkInMemory
805817 }
806818 platform = targetPlatform dflags3
807- dflags3a = updateWays $ dflags3{ways = interpWays}
819+ #if MIN_VERSION_ghc(9,0,0)
820+ evalWays = hostFullWays
821+ #else
822+ evalWays = interpWays
823+ #endif
824+ dflags3a = dflags3{ways = evalWays}
808825 dflags3b =
809826 foldl gopt_set dflags3a $
810- concatMap (wayGeneralFlags platform) interpWays
827+ concatMap (wayGeneralFlags platform) evalWays
811828 dflags3c =
812829 foldl gopt_unset dflags3b $
813- concatMap (wayUnsetGeneralFlags platform) interpWays
830+ concatMap (wayUnsetGeneralFlags platform) evalWays
814831 dflags4 =
815832 dflags3c
816833 `gopt_set` Opt_ImplicitImportQualified
0 commit comments