1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DuplicateRecordFields #-} 3{-# LANGUAGE ExtendedDefaultRules #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE LambdaCase #-} 7{-# LANGUAGE NamedFieldPuns #-} 8{-# LANGUAGE NoMonomorphismRestriction #-} 9{-# LANGUAGE OverloadedStrings #-} 10{-# LANGUAGE PatternSynonyms #-} 11{-# LANGUAGE RankNTypes #-} 12{-# LANGUAGE RecordWildCards #-} 13{-# LANGUAGE ScopedTypeVariables #-} 14{-# LANGUAGE TypeApplications #-} 15{-# LANGUAGE ViewPatterns #-} 16{-# OPTIONS_GHC -fno-warn-type-defaults #-} 17 18{- | 19A plugin inspired by the REPLoid feature of <https://github.com/jyp/dante Dante>, <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties and <https://hackage.haskell.org/package/doctest Doctest>. 20 21For a full example see the "Ide.Plugin.Eval.Tutorial" module. 22-} 23module Ide.Plugin.Eval.CodeLens ( 24 codeLens, 25 evalCommand, 26) where 27 28import CmdLineParser 29import Control.Applicative (Alternative ((<|>))) 30import Control.Arrow (second, (>>>)) 31import Control.Exception (try) 32import qualified Control.Exception as E 33import Control.Lens (_1, _3, (%~), (<&>), 34 (^.)) 35import Control.Monad (guard, join, void, when) 36import Control.Monad.IO.Class (MonadIO (liftIO)) 37import Control.Monad.Trans.Except (ExceptT (..)) 38import Data.Aeson (toJSON) 39import Data.Char (isSpace) 40import qualified Data.DList as DL 41import qualified Data.HashMap.Strict as HashMap 42import Data.List (dropWhileEnd, find, 43 intercalate, intersperse) 44import qualified Data.Map.Strict as Map 45import Data.Maybe (catMaybes, fromMaybe) 46import Data.String (IsString) 47import Data.Text (Text) 48import qualified Data.Text as T 49import Data.Time (getCurrentTime) 50import Data.Typeable (Typeable) 51import Development.IDE (Action, 52 GetDependencies (..), 53 GetModIface (..), 54 GetModSummary (..), 55 GetParsedModuleWithComments (..), 56 GhcSessionIO (..), 57 HiFileResult (hirHomeMod, hirModSummary), 58 HscEnvEq, IdeState, 59 ModSummaryResult (..), 60 evalGhcEnv, 61 hscEnvWithImportPaths, 62 prettyPrint, 63 realSrcSpanToRange, 64 runAction, 65 textToStringBuffer, 66 toNormalizedFilePath', 67 uriToFilePath', 68 useNoFile_, 69 useWithStale_, use_, 70 uses_) 71import Development.IDE.Core.Compile (loadModulesHome, 72 setupFinderCache) 73import Development.IDE.Core.PositionMapping (toCurrentRange) 74import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps)) 75import Development.IDE.GHC.Compat (AnnotationComment (AnnBlockComment, AnnLineComment), 76 GenLocated (L), 77 GhcException, HscEnv, 78 ParsedModule (..), 79 SrcSpan (UnhelpfulSpan), 80 moduleName, 81 setInteractiveDynFlags, 82 srcSpanFile) 83import qualified Development.IDE.GHC.Compat as SrcLoc 84import Development.IDE.Types.Options 85import DynamicLoading (initializePlugins) 86import FastString (unpackFS) 87import GHC (ClsInst, 88 ExecOptions (execLineNumber, execSourceFile), 89 FamInst, Fixity, 90 GeneralFlag (..), Ghc, 91 GhcLink (LinkInMemory), 92 GhcMode (CompManager), 93 GhcMonad (getSession), 94 HscTarget (HscInterpreted), 95 LoadHowMuch (LoadAllTargets), 96 ModSummary (ms_hspp_opts), 97 NamedThing (getName, getOccName), 98 SuccessFlag (Failed, Succeeded), 99 TcRnExprMode (..), 100 TyThing, defaultFixity, 101 execOptions, exprType, 102 getInfo, 103 getInteractiveDynFlags, 104 getSessionDynFlags, 105 isImport, isStmt, load, 106 parseName, pprFamInst, 107 pprInstance, runDecls, 108 setContext, setLogAction, 109 setSessionDynFlags, 110 setTargets, typeKind) 111import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) 112import GhcPlugins (DynFlags (..), 113 defaultLogActionHPutStrDoc, 114 elemNameSet, gopt_set, 115 gopt_unset, hsc_dflags, 116 isSymOcc, mkNameSet, 117 parseDynamicFlagsCmdLine, 118 pprDefinedAt, 119 pprInfixName, 120 targetPlatform, 121 tyThingParent_maybe, 122 xopt_set, xopt_unset) 123 124import HscTypes (InteractiveImport (IIModule), 125 ModSummary (ms_mod), 126 Target (Target), 127 TargetId (TargetFile)) 128import Ide.Plugin.Eval.Code (Statement, asStatements, 129 evalSetup, myExecStmt, 130 propSetup, resultRange, 131 testCheck, testRanges) 132import Ide.Plugin.Eval.GHC (addImport, addPackages, 133 hasPackage, showDynFlags) 134import Ide.Plugin.Eval.Parse.Comments (commentsToSections) 135import Ide.Plugin.Eval.Parse.Option (parseSetFlags) 136import Ide.Plugin.Eval.Types 137import Ide.Plugin.Eval.Util (asS, gStrictTry, 138 handleMaybe, 139 handleMaybeM, isLiterate, 140 logWith, response, 141 response', timed) 142import Ide.Types 143import Language.LSP.Server 144import Language.LSP.Types hiding 145 (SemanticTokenAbsolute (length, line), 146 SemanticTokenRelative (length)) 147import Language.LSP.Types.Lens (end, line) 148import Language.LSP.VFS (virtualFileText) 149import Outputable (SDoc, empty, hang, nest, 150 ppr, showSDoc, text, 151 vcat, ($$), (<+>)) 152import System.FilePath (takeFileName) 153import System.IO (hClose) 154import UnliftIO.Temporary (withSystemTempFile) 155import Util (OverridingBool (Never)) 156 157import IfaceSyn (showToHeader) 158import PprTyThing (pprTyThingInContext, 159 pprTypeForUser) 160#if MIN_VERSION_ghc(9,0,0) 161import GHC.Driver.Ways (hostFullWays, 162 wayGeneralFlags, 163 wayUnsetGeneralFlags) 164import GHC.Parser.Annotation (ApiAnns (apiAnnRogueComments)) 165import GHC.Parser.Lexer (mkParserFlags) 166import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) 167#else 168import GhcPlugins (interpWays, updateWays, 169 wayGeneralFlags, 170 wayUnsetGeneralFlags) 171#endif 172 173#if MIN_VERSION_ghc(9,0,0) 174pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan 175pattern RealSrcSpanAlready x = x 176apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment] 177apiAnnComments' = apiAnnRogueComments 178#else 179apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment] 180apiAnnComments' = concat . Map.elems . snd 181 182pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan 183pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x 184#endif 185 186 187{- | Code Lens provider 188 NOTE: Invoked every time the document is modified, not just when the document is saved. 189-} 190codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens 191codeLens st plId CodeLensParams{_textDocument} = 192 let dbg = logWith st 193 perf = timed dbg 194 in perf "codeLens" $ 195 response $ do 196 let TextDocumentIdentifier uri = _textDocument 197 fp <- handleMaybe "uri" $ uriToFilePath' uri 198 let nfp = toNormalizedFilePath' fp 199 isLHS = isLiterate fp 200 dbg "fp" fp 201 (ParsedModule{..}, posMap) <- liftIO $ 202 runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetParsedModuleWithComments nfp 203 let comments = 204 foldMap (\case 205 L (RealSrcSpanAlready real) bdy 206 | unpackFS (srcSpanFile real) == 207 fromNormalizedFilePath nfp 208 , let ran0 = realSrcSpanToRange real 209 , Just curRan <- toCurrentRange posMap ran0 210 -> 211 212 -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments', 213 -- we can concentrate on these two 214 case bdy of 215 AnnLineComment cmt -> 216 mempty { lineComments = Map.singleton curRan (RawLineComment cmt) } 217 AnnBlockComment cmt -> 218 mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt } 219 _ -> mempty 220 _ -> mempty 221 ) 222 $ apiAnnComments' pm_annotations 223 dbg "excluded comments" $ show $ DL.toList $ 224 foldMap (\(L a b) -> 225 case b of 226 AnnLineComment{} -> mempty 227 AnnBlockComment{} -> mempty 228 _ -> DL.singleton (a, b) 229 ) 230 $ apiAnnComments' pm_annotations 231 dbg "comments" $ show comments 232 233 -- Extract tests from source code 234 let Sections{..} = commentsToSections isLHS comments 235 tests = testsBySection nonSetupSections 236 cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just []) 237 let lenses = 238 [ CodeLens testRange (Just cmd') Nothing 239 | (section, ident, test) <- tests 240 , let (testRange, resultRange) = testRanges test 241 args = EvalParams (setupSections ++ [section]) _textDocument ident 242 cmd' = 243 (cmd :: Command) 244 { _arguments = Just (List [toJSON args]) 245 , _title = 246 if trivial resultRange 247 then "Evaluate..." 248 else "Refresh..." 249 } 250 ] 251 252 perf "tests" $ 253 dbg "Tests" $ 254 unwords 255 [ show (length tests) 256 , "tests in" 257 , show (length nonSetupSections) 258 , "sections" 259 , show (length setupSections) 260 , "setups" 261 , show (length lenses) 262 , "lenses." 263 ] 264 265 return $ List lenses 266 where 267 trivial (Range p p') = p == p' 268 269evalCommandName :: CommandId 270evalCommandName = "evalCommand" 271 272evalCommand :: PluginCommand IdeState 273evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd 274 275type EvalId = Int 276 277runEvalCmd :: CommandFunction IdeState EvalParams 278runEvalCmd st EvalParams{..} = 279 let dbg = logWith st 280 perf = timed dbg 281 cmd :: ExceptT String (LspM c) WorkspaceEdit 282 cmd = do 283 let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections 284 285 let TextDocumentIdentifier{_uri} = module_ 286 fp <- handleMaybe "uri" $ uriToFilePath' _uri 287 let nfp = toNormalizedFilePath' fp 288 mdlText <- moduleText _uri 289 290 session <- runGetSession st nfp 291 292 ms <- fmap msrModSummary $ 293 liftIO $ 294 runAction "runEvalCmd.getModSummary" st $ 295 use_ GetModSummary nfp 296 297 now <- liftIO getCurrentTime 298 299 let modName = moduleName $ ms_mod ms 300 thisModuleTarget = 301 Target 302 (TargetFile fp Nothing) 303 False 304 (Just (textToStringBuffer mdlText, now)) 305 306 -- Setup environment for evaluation 307 hscEnv' <- ExceptT $ fmap join $ withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> liftIO . gStrictTry . evalGhcEnv session $ do 308 env <- getSession 309 310 -- Install the module pragmas and options 311 df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms 312 313 -- Restore the original import paths 314 let impPaths = importPaths $ hsc_dflags env 315 df <- return df{importPaths = impPaths} 316 317 -- Set the modified flags in the session 318 _lp <- setSessionDynFlags df 319 320 -- property tests need QuickCheck 321 when (needsQuickCheck tests) $ void $ addPackages ["QuickCheck"] 322 dbg "QUICKCHECK NEEDS" $ needsQuickCheck tests 323 dbg "QUICKCHECK HAS" $ hasQuickCheck df 324 325 -- copy the package state to the interactive DynFlags 326 idflags <- getInteractiveDynFlags 327 df <- getSessionDynFlags 328 -- set the identical DynFlags as GHCi 329 -- Source: https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483 330 -- This needs to be done manually since the default flags are not visible externally. 331 let df' = flip xopt_set LangExt.ExtendedDefaultRules 332 . flip xopt_unset LangExt.MonomorphismRestriction 333 $ idflags 334 setInteractiveDynFlags $ df' 335#if MIN_VERSION_ghc(9,0,0) 336 { unitState = 337 unitState 338 df 339 , unitDatabases = 340 unitDatabases 341 df 342 , packageFlags = 343 packageFlags 344 df 345 , useColor = Never 346 , canUseColor = False 347 } 348#else 349 { pkgState = 350 pkgState 351 df 352 , pkgDatabase = 353 pkgDatabase 354 df 355 , packageFlags = 356 packageFlags 357 df 358 , useColor = Never 359 , canUseColor = False 360 } 361#endif 362 363 -- set up a custom log action 364#if MIN_VERSION_ghc(9,0,0) 365 setLogAction $ \_df _wr _sev _span _doc -> 366 defaultLogActionHPutStrDoc _df logHandle _doc 367#else 368 setLogAction $ \_df _wr _sev _span _style _doc -> 369 defaultLogActionHPutStrDoc _df logHandle _doc _style 370#endif 371 372 -- Load the module with its current content (as the saved module might not be up to date) 373 -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8 374 -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066 375 -- and https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#v:TargetFile 376 eSetTarget <- gStrictTry $ setTargets [thisModuleTarget] 377 dbg "setTarget" eSetTarget 378 379 -- load the module in the interactive environment 380 loadResult <- perf "loadModule" $ load LoadAllTargets 381 dbg "LOAD RESULT" $ asS loadResult 382 case loadResult of 383 Failed -> liftIO $ do 384 hClose logHandle 385 err <- readFile logFilename 386 dbg "load ERR" err 387 return $ Left err 388 Succeeded -> do 389 -- Evaluation takes place 'inside' the module 390 setContext [IIModule modName] 391 Right <$> getSession 392 393 edits <- 394 perf "edits" $ 395 liftIO $ 396 evalGhcEnv hscEnv' $ 397 runTests 398 (st, fp) 399 tests 400 401 let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] 402 let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing 403 404 return workspaceEdits 405 in perf "evalCmd" $ 406 withIndefiniteProgress "Evaluating" Cancellable $ 407 response' cmd 408 409addFinalReturn :: Text -> [TextEdit] -> [TextEdit] 410addFinalReturn mdlText edits 411 | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = 412 finalReturn mdlText : edits 413 | otherwise = edits 414 415finalReturn :: Text -> TextEdit 416finalReturn txt = 417 let ls = T.lines txt 418 l = length ls -1 419 c = T.length . last $ ls 420 p = Position l c 421 in TextEdit (Range p p) "\n" 422 423moduleText :: (IsString e, MonadLsp c m) => Uri -> ExceptT e m Text 424moduleText uri = 425 handleMaybeM "mdlText" $ 426 (virtualFileText <$>) 427 <$> getVirtualFile 428 (toNormalizedUri uri) 429 430testsBySection :: [Section] -> [(Section, EvalId, Test)] 431testsBySection sections = 432 [(section, ident, test) 433 | (ident, section) <- zip [0..] sections 434 , test <- sectionTests section 435 ] 436 437type TEnv = (IdeState, String) 438 439runTests :: TEnv -> [(Section, Test)] -> Ghc [TextEdit] 440runTests e@(_st, _) tests = do 441 df <- getInteractiveDynFlags 442 evalSetup 443 when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals e df propSetup 444 445 mapM (processTest e df) tests 446 where 447 processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit 448 processTest e@(st, fp) df (section, test) = do 449 let dbg = logWith st 450 let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) 451 452 rs <- runTest e df test 453 dbg "TEST RESULTS" rs 454 455 let checkedResult = testCheck (section, test) rs 456 457 let edit = asEdit (sectionFormat section) test (map pad checkedResult) 458 dbg "TEST EDIT" edit 459 return edit 460 461 -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text] 462 runTest _ df test 463 | not (hasQuickCheck df) && isProperty test = 464 return $ 465 singleLine 466 "Add QuickCheck to your cabal dependencies to run this test." 467 runTest e df test = evals e df (asStatements test) 468 469asEdit :: Format -> Test -> [Text] -> TextEdit 470asEdit (MultiLine commRange) test resultLines 471 -- A test in a block comment, ending with @-\}@ without newline in-between. 472 | testRange test ^. end.line == commRange ^. end . line 473 = 474 TextEdit 475 (Range 476 (testRange test ^. end) 477 (resultRange test ^. end) 478 ) 479 ("\n" <> T.unlines (resultLines <> ["-}"])) 480asEdit _ test resultLines = 481 TextEdit (resultRange test) (T.unlines resultLines) 482 483{- 484The result of evaluating a test line can be: 485* a value 486* nothing 487* a (possibly multiline) error message 488 489A value is returned for a correct expression. 490 491Either a pure value: 492>>> 'h' :"askell" 493"haskell" 494 495Or an 'IO a' (output on stdout/stderr is ignored): 496>>> print "OK" >> return "ABC" 497"ABC" 498 499Nothing is returned for a correct directive: 500 501>>>:set -XFlexibleInstances 502>>> import Data.Maybe 503 504Nothing is returned for a correct declaration (let..,x=, data, class) 505 506>>> let x = 11 507>>> y = 22 508>>> data B = T | F 509>>> class C a 510 511Nothing is returned for an empty line: 512 513>>> 514 515A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code: 516 517>>>:set -XNonExistent 518Unknown extension: "NonExistent" 519 520>>> cls C 521Variable not in scope: cls :: t0 -> () 522Data constructor not in scope: C 523 524>>> "A 525lexical error in string/character literal at end of input 526 527>>> 3 `div` 0 528divide by zero 529 530>>> error "Something went wrong\nbad times" :: E.SomeException 531Something went wrong 532bad times 533 534Or for a value that does not have a Show instance and can therefore not be displayed: 535>>> data V = V 536>>> V 537No instance for (Show V) 538-} 539evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text] 540evals (st, fp) df stmts = do 541 er <- gStrictTry $ mapM eval stmts 542 return $ case er of 543 Left err -> errorLines err 544 Right rs -> concat . catMaybes $ rs 545 where 546 dbg = logWith st 547 eval :: Statement -> Ghc (Maybe [Text]) 548 eval (Located l stmt) 549 | -- GHCi flags 550 Just (words -> flags) <- parseSetFlags stmt = do 551 dbg "{:SET" flags 552 ndf <- getInteractiveDynFlags 553 dbg "pre set" $ showDynFlags ndf 554 eans <- 555 liftIO $ try @GhcException $ 556 parseDynamicFlagsCmdLine ndf 557 (map (L $ UnhelpfulSpan unhelpfulReason) flags) 558 dbg "parsed flags" $ eans 559 <&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg) 560 case eans of 561 Left err -> pure $ Just $ errorLines $ show err 562 Right (df', ignoreds, warns) -> do 563 let warnings = do 564 guard $ not $ null warns 565 pure $ errorLines $ 566 unlines $ 567 map prettyWarn warns 568 igns = do 569 guard $ not $ null ignoreds 570 pure 571 ["Some flags have not been recognized: " 572 <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds) 573 ] 574 dbg "post set" $ showDynFlags df' 575 _ <- setSessionDynFlags df' 576 sessDyns <- getSessionDynFlags 577 setInteractiveDynFlags sessDyns 578 pure $ warnings <> igns 579 | -- A type/kind command 580 Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt = 581 evalGhciLikeCmd cmd arg 582 | -- A statement 583 isStmt pf stmt = 584 do 585 dbg "{STMT " stmt 586 res <- exec stmt l 587 r <- case res of 588 Left err -> return . Just . errorLines $ err 589 Right x -> return $ singleLine <$> x 590 dbg "STMT} -> " r 591 return r 592 | -- An import 593 isImport pf stmt = 594 do 595 dbg "{IMPORT " stmt 596 _ <- addImport stmt 597 return Nothing 598 | -- A declaration 599 otherwise = 600 do 601 dbg "{DECL " stmt 602 void $ runDecls stmt 603 return Nothing 604#if !MIN_VERSION_ghc(9,0,0) 605 pf = df 606 unhelpfulReason = "<interactive>" 607#else 608 pf = mkParserFlags df 609 unhelpfulReason = UnhelpfulInteractive 610#endif 611 exec stmt l = 612 let opts = execOptions{execSourceFile = fp, execLineNumber = l} 613 in myExecStmt stmt opts 614 615prettyWarn :: Warn -> String 616prettyWarn Warn{..} = 617 prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n" 618 <> " " <> SrcLoc.unLoc warnMsg 619 620ghcSessionDepsDefinition :: HscEnvEq -> NormalizedFilePath -> Action HscEnv 621ghcSessionDepsDefinition env file = do 622 let hsc = hscEnvWithImportPaths env 623 deps <- use_ GetDependencies file 624 let tdeps = transitiveModuleDeps deps 625 ifaces <- uses_ GetModIface tdeps 626 627 -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. 628 -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. 629 -- Long-term we might just want to change the order returned by GetDependencies 630 let inLoadOrder = reverse (map hirHomeMod ifaces) 631 632 liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc 633 634runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv 635runGetSession st nfp = liftIO $ runAction "eval" st $ do 636 -- Create a new GHC Session rather than reusing an existing one 637 -- to avoid interfering with ghcide 638 IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO 639 let fp = fromNormalizedFilePath nfp 640 ((_, res),_) <- liftIO $ loadSessionFun fp 641 let hscEnv = fromMaybe (error $ "Unknown file: " <> fp) res 642 ghcSessionDepsDefinition hscEnv nfp 643 644needsQuickCheck :: [(Section, Test)] -> Bool 645needsQuickCheck = any (isProperty . snd) 646 647hasQuickCheck :: DynFlags -> Bool 648hasQuickCheck df = hasPackage df "QuickCheck" 649 650singleLine :: String -> [Text] 651singleLine s = [T.pack s] 652 653{- | 654 Convert error messages to a list of text lines 655 Remove unnecessary information. 656-} 657errorLines :: String -> [Text] 658errorLines = 659 dropWhileEnd T.null 660 . takeWhile (not . ("CallStack" `T.isPrefixOf`)) 661 . T.lines 662 . T.pack 663 664{- | 665>>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""]) 666["--2+2","--<BLANKLINE>"] 667-} 668pad_ :: Text -> Text -> Text 669pad_ prefix = (prefix `T.append`) . convertBlank 670 671convertBlank :: Text -> Text 672convertBlank x 673 | T.null x = "<BLANKLINE>" 674 | otherwise = x 675 676padPrefix :: IsString p => Format -> p 677padPrefix SingleLine = "-- " 678padPrefix _ = "" 679 680{- | Resulting @Text@ MUST NOT prefix each line with @--@ 681 Such comment-related post-process will be taken place 682 solely in 'evalGhciLikeCmd'. 683-} 684type GHCiLikeCmd = DynFlags -> Text -> Ghc (Maybe Text) 685 686-- Should we use some sort of trie here? 687ghciLikeCommands :: [(Text, GHCiLikeCmd)] 688ghciLikeCommands = 689 [ ("info", doInfoCmd False) 690 , ("info!", doInfoCmd True) 691 , ("kind", doKindCmd False) 692 , ("kind!", doKindCmd True) 693 , ("type", doTypeCmd) 694 ] 695 696evalGhciLikeCmd :: Text -> Text -> Ghc (Maybe [Text]) 697evalGhciLikeCmd cmd arg = do 698 df <- getSessionDynFlags 699 case lookup cmd ghciLikeCommands 700 <|> snd 701 <$> find (T.isPrefixOf cmd . fst) ghciLikeCommands of 702 Just hndler -> 703 fmap 704 T.lines 705 <$> hndler df arg 706 _ -> E.throw $ GhciLikeCmdNotImplemented cmd arg 707 708doInfoCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) 709doInfoCmd allInfo dflags s = do 710 sdocs <- mapM infoThing (T.words s) 711 pure $ Just $ T.pack $ showSDoc dflags (vcat sdocs) 712 where 713 infoThing :: GHC.GhcMonad m => Text -> m SDoc 714 infoThing (T.unpack -> str) = do 715 names <- GHC.parseName str 716 mb_stuffs <- mapM (GHC.getInfo allInfo) names 717 let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t) 718 (catMaybes mb_stuffs) 719 return $ vcat (intersperse (text "") $ map pprInfo filtered) 720 721 filterOutChildren :: (a -> TyThing) -> [a] -> [a] 722 filterOutChildren get_thing xs 723 = filter (not . has_parent) xs 724 where 725 all_names = mkNameSet (map (getName . get_thing) xs) 726 has_parent x = case tyThingParent_maybe (get_thing x) of 727 Just p -> getName p `elemNameSet` all_names 728 Nothing -> False 729 730 pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc 731 pprInfo (thing, fixity, cls_insts, fam_insts, docs) 732 = docs 733 $$ pprTyThingInContextLoc thing 734 $$ showFixity thing fixity 735 $$ vcat (map GHC.pprInstance cls_insts) 736 $$ vcat (map GHC.pprFamInst fam_insts) 737 738 pprTyThingInContextLoc :: TyThing -> SDoc 739 pprTyThingInContextLoc tyThing 740 = showWithLoc (pprDefinedAt (getName tyThing)) 741 (pprTyThingInContext showToHeader tyThing) 742 743 showWithLoc :: SDoc -> SDoc -> SDoc 744 showWithLoc loc doc 745 = hang doc 2 (text "\t--" <+> loc) 746 747 showFixity :: TyThing -> Fixity -> SDoc 748 showFixity thing fixity 749 | fixity /= GHC.defaultFixity || isSymOcc (getOccName thing) 750 = ppr fixity <+> pprInfixName (GHC.getName thing) 751 | otherwise = empty 752 753doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text) 754doKindCmd False df arg = do 755 let input = T.strip arg 756 (_, kind) <- typeKind False $ T.unpack input 757 let kindText = text (T.unpack input) <+> "::" <+> pprTypeForUser kind 758 pure $ Just $ T.pack (showSDoc df kindText) 759doKindCmd True df arg = do 760 let input = T.strip arg 761 (ty, kind) <- typeKind True $ T.unpack input 762 let kindDoc = text (T.unpack input) <+> "::" <+> pprTypeForUser kind 763 tyDoc = "=" <+> pprTypeForUser ty 764 pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc) 765 766doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) 767doTypeCmd dflags arg = do 768 let (emod, expr) = parseExprMode arg 769 ty <- exprType emod $ T.unpack expr 770 let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty 771 broken = T.any (\c -> c == '\r' || c == '\n') rawType 772 pure $ 773 Just $ 774 if broken 775 then 776 T.pack $ 777 showSDoc dflags $ 778 text (T.unpack expr) 779 $$ nest 2 ("::" <+> pprTypeForUser ty) 780 else expr <> " :: " <> rawType <> "\n" 781 782parseExprMode :: Text -> (TcRnExprMode, T.Text) 783parseExprMode rawArg = case T.break isSpace rawArg of 784 ("+v", rest) -> (TM_NoInst, T.strip rest) 785 ("+d", rest) -> (TM_Default, T.strip rest) 786 _ -> (TM_Inst, rawArg) 787 788data GhciLikeCmdException = GhciLikeCmdNotImplemented 789 { ghciCmdName :: Text 790 , ghciCmdArg :: Text 791 } 792 deriving (Typeable) 793 794instance Show GhciLikeCmdException where 795 showsPrec _ GhciLikeCmdNotImplemented{..} = 796 showString "unknown command '" 797 . showString (T.unpack ghciCmdName) 798 . showChar '\'' 799 800instance E.Exception GhciLikeCmdException 801 802{- 803>>> parseGhciLikeCmd (T.pack ":kind! N + M + 1") 804Just ("kind!","N + M + 1") 805>>> parseGhciLikeCmd (T.pack ":kind a") 806Just ("kind","a") 807-} 808parseGhciLikeCmd :: Text -> Maybe (Text, Text) 809parseGhciLikeCmd input = do 810 (':', rest) <- T.uncons $ T.stripStart input 811 pure $ second T.strip $ T.break isSpace rest 812 813setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags 814setupDynFlagsForGHCiLike env dflags = do 815 let dflags3 = 816 dflags 817 { hscTarget = HscInterpreted 818 , ghcMode = CompManager 819 , ghcLink = LinkInMemory 820 } 821 platform = targetPlatform dflags3 822#if MIN_VERSION_ghc(9,0,0) 823 evalWays = hostFullWays 824#else 825 evalWays = interpWays 826#endif 827 dflags3a = dflags3{ways = evalWays} 828 dflags3b = 829 foldl gopt_set dflags3a $ 830 concatMap (wayGeneralFlags platform) evalWays 831 dflags3c = 832 foldl gopt_unset dflags3b $ 833 concatMap (wayUnsetGeneralFlags platform) evalWays 834 dflags4 = 835 dflags3c 836 `gopt_set` Opt_ImplicitImportQualified 837 `gopt_set` Opt_IgnoreOptimChanges 838 `gopt_set` Opt_IgnoreHpcChanges 839 `gopt_unset` Opt_DiagnosticsShowCaret 840 initializePlugins env dflags4 841