clash-ghc 1.10.2 → 1.10.3
raw patch · 23 files changed
+8412/−288 lines, 23 filesdep ~clash-libdep ~clash-preludedep ~ghcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: clash-lib, clash-prelude, ghc, ghc-bignum, ghc-boot, ghci, template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +44/−0
- clash-ghc.cabal +18/−10
- src-bin-9.10.1/Clash/GHCi/UI.hs +2/−0
- src-bin-9.10.2/Clash/GHCi/UI.hs +2/−0
- src-bin-9.12/Clash/GHCi/UI.hs +2/−0
- src-bin-9.14/Clash/GHC/Driver/Session/Lint.hs +124/−0
- src-bin-9.14/Clash/GHC/Driver/Session/Mode.hs +343/−0
- src-bin-9.14/Clash/GHCi/Leak.hs +88/−0
- src-bin-9.14/Clash/GHCi/UI.hs +5120/−0
- src-bin-9.14/Clash/GHCi/UI/Exception.hs +566/−0
- src-bin-9.14/Clash/GHCi/UI/Info.hs +395/−0
- src-bin-9.14/Clash/GHCi/UI/Monad.hs +547/−0
- src-bin-9.14/Clash/GHCi/UI/Print.hs +92/−0
- src-bin-9.14/Clash/GHCi/Util.hs +16/−0
- src-bin-9.14/Clash/Main.hs +595/−0
- src-bin-9.6/Clash/GHCi/UI.hs +2/−0
- src-bin-9.8/Clash/GHCi/UI.hs +2/−0
- src-ghc/Clash/GHC/Evaluator.hs +5/−2
- src-ghc/Clash/GHC/Evaluator/Primitive.hs +71/−29
- src-ghc/Clash/GHC/GHC2Core.hs +97/−29
- src-ghc/Clash/GHC/LoadInterfaceFiles.hs +2/−2
- src-ghc/Clash/GHC/LoadModules.hs +67/−13
- src-ghc/Clash/GHC/NetlistTypes.hs +212/−203
CHANGELOG.md view
@@ -1,5 +1,48 @@ # Changelog for the Clash project +## 1.10.3 - *14 Oct, 2026*++### Added:+- Added support for GHC 9.14.+ [#3182](https://github.com/clash-lang/clash-compiler/pull/3182)+- Add `NumConvert` support for converting from `SNat`+ [#3455](https://github.com/clash-lang/clash-compiler/pull/3455)++### Changed:+- Normalization now knows which `Term` constructors each transformation can fire on, and only offers a node to the transformations that can match it. Measured ~25% faster HDL generation end-to-end on a large industrial design, with identical HDL. Transformations that cannot match a node no longer show up in `-fclash-debug-transformations` and `-fclash-debug-count-transformations` output.+ [#3328](https://github.com/clash-lang/clash-compiler/pull/3328)+- `Clash.Signal.Internal.resetGenN` now reports `clash-non-synthesizable` on every backend, instead of only on SystemVerilog.+ [#3410](https://github.com/clash-lang/clash-compiler/pull/3410)+- In `clash-lib`, the `reduceNonRepPrim` transformation is renamed to `reducePrim`, because it replaces primitives for more reasons than non-representable arguments or results. To debug it with `-fclash-debug-transformations`, use the new name.+ [#3462](https://github.com/clash-lang/clash-compiler/pull/3462)+- In `clash-lib`, the `inlineWorkFree` transformation now normalizes an application of a function to constant arguments only once, and reuses the result at every place the same application occurs. Before, every occurrence was normalized separately. This speeds up normalization of designs that compute a lot with type-level naturals at compile time, for example through `KnownNat` constraints.+ [#3472](https://github.com/clash-lang/clash-compiler/pull/3472)++### Fixed:+- Clash no longer errors when unused arguments of local functions are non-representable in very specific circumstances+ [#3407](https://github.com/clash-lang/clash-compiler/issues/3407)+- `ensureSpine` on a `Signal` no longer crashes Clash with an internal error. It now applies the sample's `ensureSpine` instance in HDL, preserving fixed bits in custom representations. Undefined stream recovery in simulation uses the same instance instead of `deepErrorX`, fixing mismatches for function-valued samples.+ [#3432](https://github.com/clash-lang/clash-compiler/issues/3432)+- Functions testing for `XException` (`isX`, `hasX`, `maybeIsX`, and `maybeHasX`) are now marked non-translatable. This makes the Clash compiler throw a proper error, instead of an internal one when it encounters their use.+ [#3434](https://github.com/clash-lang/clash-compiler/pull/3434)+- Clash no longer crashes when generating HDL for `toEnum` on an enumeration with a single constructor.+ [#3439](https://github.com/clash-lang/clash-compiler/issues/3439)+- Clash now reports an error when using GHC 9.12.1 through 9.12.3, which contain bugs affecting Clash. The GHC compatibility matrix now lists 9.12.4 as the minimum supported GHC 9.12 release.+ [#3415](https://github.com/clash-lang/clash-compiler/issues/3415)+- Extending arithmetic (`add`, `sub`, and `mul`) on `Index` now handles zero-width+ arguments correctly. VHDL subtraction from zero-width `BitVector`, `Signed`, and+ `Unsigned` values now negates the widened operand correctly, including boundary+ values.+ [#3310](https://github.com/clash-lang/clash-compiler/issues/3310)+- Clash now checks all input targets before loading modules or generating HDL. Invalid arguments, including Clash flags passed without their leading dash, are reported immediately, instead of after compiling earlier inputs.+ [#3314](https://github.com/clash-lang/clash-compiler/issues/3314)+- Projecting a zero-width field, such as a `CallStack`, no longer renders a reference to an undeclared `c$sel` in the HDL in very specific circumstances.+ [#3460](https://github.com/clash-lang/clash-compiler/issues/3460)+- Clash no longer takes minutes to compile designs that unroll `map`, `zipWith`, `foldr`, or `init` over vectors bound to top-level definitions. This most often happened with modules compiled with `-ffull-laziness`, which is enabled by `-O`, for example by Cabal.+ [#3461](https://github.com/clash-lang/clash-compiler/issues/3461)+- Fixed accidental free variable capture in `appProp`, which could produce subtly incorrect HDL.+ [#3478](https://github.com/clash-lang/clash-compiler/issues/3478)+ ## 1.10.2 *Sep 4th, 2026* Highlights:@@ -60,6 +103,7 @@ * In `clash-ghc`, Clash no longer enables `-dynamic-too` when the build is already dynamic, which made GHC emit an `-Winconsistent-flags` warning. See [#3354](https://github.com/clash-lang/clash-compiler/issues/3354), fixed in [#3358](https://github.com/clash-lang/clash-compiler/pull/3358). * In `clash-lib`, the SystemVerilog backend no longer emits out-of-bounds array indices when a nested modifier selects a half of an `RTree`. The size of a tree half was computed as `(d-1)^2` instead of `2^(d-1)`, so for an `RTree 3` the right half was emitted as `[4:8]` on an array whose valid indices are `0..7`. See [#3359](https://github.com/clash-lang/clash-compiler/issues/3359), fixed in [#3360](https://github.com/clash-lang/clash-compiler/pull/3360). * In `clash-lib` and `clash-ghc`, structural equality and ordering now account for the names and types of variables, including in `eqTerm` and `eqType`, instead of relying only on variable uniques. See [#3361](https://github.com/clash-lang/clash-compiler/issues/3361), fixed in [#3362](https://github.com/clash-lang/clash-compiler/pull/3362).+* `popCount`, `countLeadingZeros` and `countTrailingZeros` on `BitVector` (and hence on `Unsigned`, `Signed` and `Index`, which delegate to it) went through `Integer`, which made Clash emit a `Dubious primitive instantiation` warning for `GHC.Num.Integer.integerToInt#` and put an `Integer` in the generated HDL. They now use `Clash.Sized.Internal.Index.fromEnum#`, which has a black box of its own. See [#3409](https://github.com/clash-lang/clash-compiler/pull/3409). ## 1.10.1 *Aug 27th, 2026*
clash-ghc.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-ghc-Version: 1.10.2+Version: 1.10.3 Synopsis: Clash: a functional hardware description language - GHC frontend Description: Clash is a functional hardware description language that borrows both its@@ -46,7 +46,8 @@ tested-with: GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3,- GHC == 9.12.4+ GHC == 9.12.4,+ GHC == 9.14.1 Extra-source-files: README.md, CHANGELOG.md,@@ -137,7 +138,9 @@ library import: common-options HS-Source-Dirs: src-ghc, src-bin-common- if impl(ghc >= 9.12.0)+ if impl(ghc >= 9.14.0)+ HS-Source-Dirs: src-bin-9.14+ elif impl(ghc >= 9.12.0) HS-Source-Dirs: src-bin-9.12 elif impl(ghc >= 9.10.2) HS-Source-Dirs: src-bin-9.10.2@@ -173,23 +176,23 @@ text >= 1.2.2 && < 2.2, transformers >= 0.5.2.0 && < 0.7, unordered-containers >= 0.2.1.0 && < 0.3,- clash-lib == 1.10.2,- clash-prelude == 1.10.2,+ clash-lib == 1.10.3,+ clash-prelude == 1.10.3, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, deepseq >= 1.3.0.2 && < 1.6, time >= 1.4.0.1 && < 1.17,- ghc >= 9.6.0 && < 9.13,- ghc-bignum >= 1.0 && < 1.4,- ghc-boot >= 9.6.0 && < 9.13,+ ghc >= 9.6.0 && < 9.15,+ ghc-bignum >= 1.0 && < 1.5,+ ghc-boot >= 9.6.0 && < 9.15, ghc-prim >= 0.10 && < 0.14,- ghci >= 9.6.0 && < 9.13,+ ghci >= 9.6.0 && < 9.15, uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0, primitive >= 0.5.0.1 && < 1.0, string-interpolate >= 0.3 && < 1.1,- template-haskell >= 2.8.0.0 && < 2.24,+ template-haskell >= 2.8.0.0 && < 2.25, utf8-string >= 1.0.0.0 && < 1.1.0.0, vector >= 0.11 && < 1.0, exceptions >= 0.10.4 && < 0.11,@@ -238,3 +241,8 @@ Other-Modules: Clash.GHCi.UI.Exception else Other-Modules: Clash.GHCi.UI.Tags++ if impl(ghc >= 9.14.0)+ Other-Modules: Clash.GHCi.UI.Print+ Clash.GHC.Driver.Session.Lint+ Clash.GHC.Driver.Session.Mode
src-bin-9.10.1/Clash/GHCi/UI.hs view
@@ -2444,6 +2444,8 @@ -> [FilePath] -> m () makeHDL Proxy startAction optsRef srcs = do+ -- Validate every target before loading or synthesizing any of them.+ mapM_ (\src -> GHC.guessTarget src Nothing Nothing) srcs dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef
src-bin-9.10.2/Clash/GHCi/UI.hs view
@@ -2459,6 +2459,8 @@ -> [FilePath] -> m () makeHDL Proxy startAction optsRef srcs = do+ -- Validate every target before loading or synthesizing any of them.+ mapM_ (\src -> GHC.guessTarget src Nothing Nothing) srcs dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef
src-bin-9.12/Clash/GHCi/UI.hs view
@@ -2437,6 +2437,8 @@ -> [FilePath] -> m () makeHDL Proxy startAction optsRef srcs = do+ -- Validate every target before loading or synthesizing any of them.+ mapM_ (\src -> GHC.guessTarget src Nothing Nothing) srcs dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef
+ src-bin-9.14/Clash/GHC/Driver/Session/Lint.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}+module Clash.GHC.Driver.Session.Lint (checkOptions) where++import GHC.Driver.Backend+import GHC.Driver.Phases+import GHC.Driver.Session+import GHC.Platform.Ways++import GHC.Utils.Misc+import GHC.Utils.Panic++import GHC.Data.Maybe++import System.IO+import Control.Monad+import qualified Data.Set as Set+import Prelude++import Clash.GHC.Driver.Session.Mode++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ()+ -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions mode dflags srcs objs units = do+ -- Complain about any unknown flags+ let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++ when (not (Set.null (rtsWays (ways dflags)))+ && isInterpretiveMode mode) $+ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++ -- -prof and --interactive are not a good combination+ when ((fullWays (ways dflags) /= hostFullWays)+ && LinkInMemory == ghcLink dflags+ && not (gopt Opt_ExternalInterpreter dflags)) $+ do throwGhcException (UsageError+ "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")+ -- -ohi sanity check+ if (isJust (outputHi dflags) &&+ (isCompManagerMode mode || srcs `lengthExceeds` 1))+ then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")+ else do++ if (isJust (dynOutputHi dflags) &&+ (isCompManagerMode mode || srcs `lengthExceeds` 1))+ then throwGhcException (UsageError "-dynohi can only be used when compiling a single source file")+ else do++ -- -o sanity checking+ if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+ && not (isLinkMode mode))+ then throwGhcException (UsageError "can't apply -o to multiple source files")+ else do++ let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)++ when (not_linking && not (null objs)) $+ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++ -- Check that there are some input files+ -- (except in the interactive case)+ if null srcs && (null objs || not_linking) && needsInputsMode mode && null units+ then throwGhcException (UsageError "no input files" )+ else do++ case mode of+ StopBefore StopC | not (backendGeneratesHc (backend dflags))+ -> throwGhcException $ UsageError $+ "the option -C is only available with an unregisterised GHC"+ StopBefore StopAs | ghcLink dflags == NoLink+ -> throwGhcException $ UsageError $+ "the options -S and -fno-code are incompatible. Please omit -S"++ _ -> return ()++ -- Verify that output files point somewhere sensible.+ verifyOutputFiles dflags++-- Compiler output options++-- Called to verify that the output files point somewhere valid.+--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+--+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if+-- they don't exist, so don't check for those here (#2278).+verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+ let ofile = outputFile dflags+ when (isJust ofile) $ do+ let fn = fromJust ofile+ flg <- doesDirNameExist fn+ when (not flg) (nonExistentDir "-o" fn)+ let ohi = outputHi dflags+ when (isJust ohi) $ do+ let hi = fromJust ohi+ flg <- doesDirNameExist hi+ when (not flg) (nonExistentDir "-ohi" hi)+ where+ nonExistentDir flg dir =+ throwGhcException (CmdLineError ("error: directory portion of " +++ show dir ++ " does not exist (used with " +++ show flg ++ " option.)"))++-- | Utility for reporting unknown flag error+unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case flagSuggestions (nubSort allNonDeprecatedFlags) f of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))
+ src-bin-9.14/Clash/GHC/Driver/Session/Mode.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}+module Clash.GHC.Driver.Session.Mode where++import GHC.Driver.CmdLine+import GHC.Driver.Phases+import GHC.Driver.Session+import GHC.Unit.Module ( ModuleName, mkModuleName )++import GHC.Types.SrcLoc++import GHC.Utils.Panic++import GHC.Data.Maybe++-- Standard Haskell libraries+import System.IO+import Control.Monad+import Data.Char+import Prelude++-----------------------------------------------------------------------------+-- GHC modes of operation++type Mode = Either PreStartupMode PostStartupMode+type PostStartupMode = Either PreLoadMode PostLoadMode++data PreStartupMode+ = ShowVersion -- ghc -V/--version+ | ShowNumVersion -- ghc --numeric-version+ | ShowSupportedExtensions -- ghc --supported-extensions+ | ShowOptions Bool {- isInteractive -} -- ghc --show-options++showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode+showVersionMode = mkPreStartupMode ShowVersion+showNumVersionMode = mkPreStartupMode ShowNumVersion+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions+showOptionsMode = mkPreStartupMode (ShowOptions False)++mkPreStartupMode :: PreStartupMode -> Mode+mkPreStartupMode = Left++isShowVersionMode :: Mode -> Bool+isShowVersionMode (Left ShowVersion) = True+isShowVersionMode _ = False++isShowNumVersionMode :: Mode -> Bool+isShowNumVersionMode (Left ShowNumVersion) = True+isShowNumVersionMode _ = False++data PreLoadMode+ = ShowGhcUsage -- ghc -?+ | ShowGhciUsage -- ghci -?+ | ShowInfo -- ghc --info+ | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo++showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode+showGhcUsageMode = mkPreLoadMode ShowGhcUsage+showGhciUsageMode = mkPreLoadMode ShowGhciUsage+showInfoMode = mkPreLoadMode ShowInfo++printSetting :: String -> Mode+printSetting k = mkPreLoadMode (PrintWithDynFlags f)+ where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))+ $ lookup k (compilerInfo dflags)++mkPreLoadMode :: PreLoadMode -> Mode+mkPreLoadMode = Right . Left++isShowGhcUsageMode :: Mode -> Bool+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True+isShowGhcUsageMode _ = False++isShowGhciUsageMode :: Mode -> Bool+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True+isShowGhciUsageMode _ = False++data PostLoadMode+ = ShowInterface FilePath -- ghc --show-iface+ | DoMkDependHS -- ghc -M+ | StopBefore StopPhase -- ghc -E | -C | -S+ -- StopBefore StopLn is the default+ | DoMake -- ghc --make+ | DoBackpack -- ghc --backpack foo.bkp+ | DoInteractive -- ghc --interactive+ | DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]+ | DoRun -- ghc --run+ | DoAbiHash -- ghc --abi-hash+ | ShowPackages -- ghc --show-packages+ | DoFrontend ModuleName -- ghc --frontend Plugin.Module+ | DoVHDL -- ghc --vhdl+ | DoVerilog -- ghc --verilog+ | DoSystemVerilog -- ghc --systemverilog++doMkDependHSMode, doMakeMode, doInteractiveMode, doRunMode,+ doAbiHashMode, showUnitsMode, doVHDLMode, doVerilogMode,+ doSystemVerilogMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doRunMode = mkPostLoadMode DoRun+doAbiHashMode = mkPostLoadMode DoAbiHash+showUnitsMode = mkPostLoadMode ShowPackages+doVHDLMode = mkPostLoadMode DoVHDL+doVerilogMode = mkPostLoadMode DoVerilog+doSystemVerilogMode = mkPostLoadMode DoSystemVerilog++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: StopPhase -> Mode+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)++doEvalMode :: String -> Mode+doEvalMode str = mkPostLoadMode (DoEval [str])++doFrontendMode :: String -> Mode+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))++doBackpackMode :: Mode+doBackpackMode = mkPostLoadMode DoBackpack++mkPostLoadMode :: PostLoadMode -> Mode+mkPostLoadMode = Right . Right++isDoInteractiveMode :: Mode -> Bool+isDoInteractiveMode (Right (Right DoInteractive)) = True+isDoInteractiveMode _ = False++isStopLnMode :: Mode -> Bool+isStopLnMode (Right (Right (StopBefore NoStop))) = True+isStopLnMode _ = False++isDoMakeMode :: Mode -> Bool+isDoMakeMode (Right (Right DoMake)) = True+isDoMakeMode _ = False++isDoEvalMode :: Mode -> Bool+isDoEvalMode (Right (Right (DoEval _))) = True+isDoEvalMode _ = False++#if defined(HAVE_INTERNAL_INTERPRETER)+isInteractiveMode :: PostLoadMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _ = False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: PostLoadMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _) = True+isInterpretiveMode _ = False++needsInputsMode :: PostLoadMode -> Bool+needsInputsMode DoMkDependHS = True+needsInputsMode (StopBefore _) = True+needsInputsMode DoMake = True+needsInputsMode DoVHDL = True+needsInputsMode DoVerilog = True+needsInputsMode DoSystemVerilog = True+needsInputsMode _ = False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: PostLoadMode -> Bool+isLinkMode (StopBefore NoStop) = True+isLinkMode DoMake = True+isLinkMode DoRun = True+isLinkMode DoInteractive = True+isLinkMode (DoEval _) = True+isLinkMode _ = False++isCompManagerMode :: PostLoadMode -> Bool+isCompManagerMode DoRun = True+isCompManagerMode DoMake = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _) = True+isCompManagerMode DoVHDL = True+isCompManagerMode DoVerilog = True+isCompManagerMode DoSystemVerilog = True+isCompManagerMode _ = False++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+ -> IO (Mode, [String],+ [Located String],+ [Warn])+parseModeFlags args = do+ ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) <-+ processCmdLineP mode_flags (Nothing, [], [], []) args+ let mode = case mModeFlag of+ Nothing -> doMakeMode+ Just (m, _) -> m++ -- See Note [Handling errors when parsing command-line flags]+ unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $+ map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2++ return (mode, units, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe (Mode, String), [String], [String], [Located String])+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+ -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+ [ ------- help / version ----------------------------------------------+ defFlag "?" (PassFlag (setMode showGhcUsageMode))+ , defFlag "-help" (PassFlag (setMode showGhcUsageMode))+ , defFlag "V" (PassFlag (setMode showVersionMode))+ , defFlag "-version" (PassFlag (setMode showVersionMode))+ , defFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))+ , defFlag "-info" (PassFlag (setMode showInfoMode))+ , defFlag "-show-options" (PassFlag (setMode showOptionsMode))+ , defFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+ , defFlag "-show-packages" (PassFlag (setMode showUnitsMode))+ ] +++ [ defFlag k' (PassFlag (setMode (printSetting k)))+ | k <- ["Project version",+ "Project Git commit id",+ "Booter version",+ "Stage",+ "Build platform",+ "Host platform",+ "Target platform",+ "Have interpreter",+ "Object splitting supported",+ "Have native code generator",+ "Support SMP",+ "Unregisterised",+ "Tables next to code",+ "RTS ways",+ "Leading underscore",+ "Debug on",+ "LibDir",+ "Global Package DB",+ "C compiler flags",+ "C compiler link flags"+ ],+ let k' = "-print-" ++ map (replaceSpace . toLower) k+ replaceSpace ' ' = '-'+ replaceSpace c = c+ ] +++ ------- interfaces ----------------------------------------------------+ [ defFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)+ "--show-iface"))++ ------- primary modes ------------------------------------------------+ , defFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode NoStop) f+ addFlag "-no-link" f))+ , defFlag "M" (PassFlag (setMode doMkDependHSMode))+ , defFlag "E" (PassFlag (setMode (stopBeforeMode StopPreprocess )))+ , defFlag "C" (PassFlag (setMode (stopBeforeMode StopC)))+ , defFlag "S" (PassFlag (setMode (stopBeforeMode StopAs)))+ , defFlag "-run" (PassFlag (setMode doRunMode))+ , defFlag "-make" (PassFlag (setMode doMakeMode))+ , defFlag "unit" (SepArg (\s -> addUnit s "-unit"))+ , defFlag "-backpack" (PassFlag (setMode doBackpackMode))+ , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))+ , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))+ , defFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))+ , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend"))+ , defFlag "-vhdl" (PassFlag (setMode doVHDLMode))+ , defFlag "-verilog" (PassFlag (setMode doVerilogMode))+ , defFlag "-systemverilog" (PassFlag (setMode doSystemVerilogMode))+ ]++addUnit :: String -> String -> EwM ModeM ()+addUnit unit_str _arg = liftEwM $ do+ (mModeFlag, units, errs, flags') <- getCmdLineState+ putCmdLineState (mModeFlag, unit_str:units, errs, flags')++setMode :: Mode -> String -> EwM ModeM ()+setMode newMode newFlag = liftEwM $ do+ (mModeFlag, units, errs, flags') <- getCmdLineState+ let (modeFlag', errs') =+ case mModeFlag of+ Nothing -> ((newMode, newFlag), errs)+ Just (oldMode, oldFlag) ->+ case (oldMode, newMode) of+ -- -c/--make are allowed together, and mean --make -no-link+ _ | isStopLnMode oldMode && isDoMakeMode newMode+ || isStopLnMode newMode && isDoMakeMode oldMode ->+ ((doMakeMode, "--make"), [])++ -- If we have both --help and --interactive then we+ -- want showGhciUsage+ _ | isShowGhcUsageMode oldMode &&+ isDoInteractiveMode newMode ->+ ((showGhciUsageMode, oldFlag), [])+ | isShowGhcUsageMode newMode &&+ isDoInteractiveMode oldMode ->+ ((showGhciUsageMode, newFlag), [])++ -- If we have both -e and --interactive then -e always wins+ _ | isDoEvalMode oldMode &&+ isDoInteractiveMode newMode ->+ ((oldMode, oldFlag), [])+ | isDoEvalMode newMode &&+ isDoInteractiveMode oldMode ->+ ((newMode, newFlag), [])++ -- Otherwise, --help/--version/--numeric-version always win+ | isDominantFlag oldMode -> ((oldMode, oldFlag), [])+ | isDominantFlag newMode -> ((newMode, newFlag), [])+ -- We need to accumulate eval flags like "-e foo -e bar"+ (Right (Right (DoEval esOld)),+ Right (Right (DoEval [eNew]))) ->+ ((Right (Right (DoEval (eNew : esOld))), oldFlag),+ errs)+ -- Saying e.g. --interactive --interactive is OK+ _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)++ -- --interactive and --show-options are used together+ (Right (Right DoInteractive), Left (ShowOptions _)) ->+ ((Left (ShowOptions True),+ "--interactive --show-options"), errs)+ (Left (ShowOptions _), (Right (Right DoInteractive))) ->+ ((Left (ShowOptions True),+ "--show-options --interactive"), errs)+ -- Otherwise, complain+ _ -> let err = flagMismatchErr oldFlag newFlag+ in ((oldMode, oldFlag), err : errs)+ putCmdLineState (Just modeFlag', units, errs', flags')+ where isDominantFlag f = isShowGhcUsageMode f ||+ isShowGhciUsageMode f ||+ isShowVersionMode f ||+ isShowNumVersionMode f++flagMismatchErr :: String -> String -> String+flagMismatchErr oldFlag newFlag+ = "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"++addFlag :: String -> String -> EwM ModeM ()+addFlag s flag = liftEwM $ do+ (m, units, e, flags') <- getCmdLineState+ putCmdLineState (m, units, e, mkGeneralLocated loc s : flags')+ where loc = "addFlag by " ++ flag ++ " on the commandline"
+ src-bin-9.14/Clash/GHCi/Leak.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module Clash.GHCi.Leak+ ( LeakIndicators+ , getLeakIndicators+ , checkLeakIndicators+ ) where++import Clash.GHCi.Util+import Control.Monad+import Data.Bits+import Data.IORef+import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)+import GHC+import GHC.Ptr (Ptr (..))+import GHC.Driver.Env+import GHC.Driver.Ppr+import GHC.Utils.Outputable+import GHC.Unit.Module.ModDetails+import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable+import GHC.Platform (target32Bit)+import GHC.Linker.Types+import Prelude+import System.Mem+import System.Mem.Weak+import GHC.Types.Unique.DFM+import Control.Exception++-- Checking for space leaks in GHCi. See #15111, and the+-- -fghci-leak-check flag.++data LeakIndicators = LeakIndicators [LeakModIndicators]++data LeakModIndicators = LeakModIndicators+ { leakMod :: Weak HomeModInfo+ , leakIface :: Weak ModIface+ , leakDetails :: Weak ModDetails+ , leakLinkable :: [Maybe (Weak Linkable)]+ }++-- | Grab weak references to some of the data structures representing+-- the currently loaded modules.+getLeakIndicators :: HscEnv -> IO LeakIndicators+getLeakIndicators hsc_env =+ fmap LeakIndicators $ do+ hpt <- readIORef $ hptInternalTableRef $ hsc_HPT hsc_env+ forM (eltsUDFM hpt) $ \hmi@HomeModInfo{..} -> do+ leakMod <- mkWeakPtr hmi Nothing+ leakIface <- mkWeakPtr hm_iface Nothing+ leakDetails <- mkWeakPtr hm_details Nothing+ leakLinkable <- mkWeakLinkables hm_linkable+ return $ LeakModIndicators{..}+ where+ mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]+ mkWeakLinkables (HomeModLinkable mbc mo) =+ mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo]++-- | Look at the LeakIndicators collected by an earlier call to+-- `getLeakIndicators`, and print messasges if any of them are still+-- alive.+checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()+checkLeakIndicators dflags (LeakIndicators leakmods) = do+ performGC+ forM_ leakmods $ \LeakModIndicators{..} -> do+ deRefWeak leakMod >>= \case+ Nothing -> return ()+ Just hmi ->+ report ("HomeModInfo for " +++ showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)+ deRefWeak leakIface >>= \case+ Nothing -> return ()+ Just miface -> report ("ModIface:" ++ moduleNameString (moduleName (mi_module miface))) (Just miface)+ deRefWeak leakDetails >>= report "ModDetails"+ forM_ leakLinkable $ \l -> forM_ l $ \l' -> deRefWeak l' >>= report "Linkable"+ where+ report :: String -> Maybe a -> IO ()+ report _ Nothing = return ()+ report msg (Just a) = do+ addr <- anyToPtr a+ putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " +++ show (maskTagBits addr))++ tagBits+ | target32Bit (targetPlatform dflags) = 2+ | otherwise = 3++ maskTagBits :: Ptr a -> Ptr a+ maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1))
+ src-bin-9.14/Clash/GHCi/UI.hs view
@@ -0,0 +1,5120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++{-# OPTIONS -fno-warn-name-shadowing #-}+-- This module does a lot of it++-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI (+ interactiveUI,+ GhciSettings(..),+ defaultGhciSettings,+ ghciCommands,+ ghciWelcomeMsg,+ makeHDL+ ) where++-- GHCi+import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )+import Clash.GHCi.UI.Monad hiding ( args, runStmt )+import Clash.GHCi.UI.Info+import Clash.GHCi.UI.Exception hiding (GHCi)++import GHC.Runtime.Debugger+import GHC.Runtime.Debugger.Breakpoints+import GHC.Runtime.Eval (mkTopLevEnv)+import GHC.Runtime.Eval.Utils++-- The GHC interface+import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod)+import GHC.Runtime.Interpreter+import GHCi.RemoteTypes+import GHCi.BreakArray( breakOn, breakOff )+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.PatSyn+import GHC.Driver.Flags+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Phases+import GHC.Driver.Session as DynFlags+import GHC.Driver.Ppr hiding (printForUser)+import GHC.Utils.Error hiding (traceCmd)+import GHC.Driver.Monad ( modifySession, modifySessionM )+import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) )+import GHC.Driver.Config.Parser+import GHC.Driver.Config.Diagnostic+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..), TargetId(..),+ Resume, SingleStep, Ghc,+ GetDocsFailure(..), pushLogHookM,+ getModuleGraph, handleSourceError,+ BreakpointId(..) )+import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation)+import GHC.Hs.ImpExp+import GHC.Hs+import GHC.Driver.Env+import GHC.Runtime.Context+import GHC.Types.TyThing+import GHC.Types.TyThing.Ppr+import GHC.Core.TyCo.Ppr+import GHC.Types.SafeHaskell ( getSafeMode )+import GHC.Types.SourceError ( SourceError )+import GHC.Types.Name+import GHC.Types.Var ( varType )+import GHC.Iface.Syntax ( showToHeader )+import GHC.Builtin.Names+import GHC.Builtin.Types( stringTyCon_RDR )+import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName, greName, globalRdrEnvElts)+import GHC.Types.SrcLoc as SrcLoc+import qualified GHC.Parser.Lexer as Lexer+import GHC.Parser.Header ( toArgs )+import qualified GHC.Parser.Header as Header+import GHC.Types.PkgQual++import GHC.Unit+import GHC.Unit.Finder as Finder+import GHC.Unit.Module.Graph (filterToposortToModules)+import GHC.Unit.Module.ModSummary++import GHC.Data.StringBuffer+import GHC.Utils.Outputable+import GHC.Utils.Logger++-- Other random utilities+import GHC.Types.Basic hiding ( isTopLevel )+import GHC.Data.Graph.Directed+import GHC.Utils.Encoding+import GHC.Data.FastString+import qualified GHC.Linker.Loader as Loader+import GHC.Data.Maybe ( expectJust )+import GHC.Types.Name.Set+import GHC.Utils.Panic hiding ( showException, try )+import GHC.Utils.Misc+import qualified GHC.LanguageExtensions as LangExt+import qualified GHC.Data.Strict as Strict+import GHC.Types.Error+import qualified GHC.Unit.Home.Graph as HUG++-- Haskell Libraries+import System.Console.Haskeline as Haskeline++import Control.Applicative hiding (empty)+import Control.DeepSeq (deepseq)+import Control.Monad as Monad+import Control.Monad.Catch as MC+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Array+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Function+import qualified Data.Foldable as Foldable+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( find, intercalate, intersperse,+ isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as S+import Data.Maybe+import qualified Data.Map as M+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )+import qualified Data.Semigroup as S+import Prelude hiding ((<>))++import GHC.Utils.Exception as Exception hiding (catch, mask, handle)+import Foreign hiding (void)+import GHC.Stack hiding (SrcLoc(..))+import GHC.Unit.Env+import GHC.Unit.Home.PackageTable++import System.Directory+import System.Environment+import System.Exit ( exitWith, ExitCode(..) )+import System.FilePath+import System.Info+import System.IO+import System.IO.Error+import System.IO.Unsafe ( unsafePerformIO )+import System.Process+import Text.Printf+import Text.Read ( readMaybe )+import Text.Read.Lex (isSymbolChar)++import Unsafe.Coerce++#if !defined(mingw32_HOST_OS)+import System.Posix hiding ( getEnv )+#else+import qualified System.Win32+#endif++import GHC.IO.Exception ( IOErrorType(InvalidArgument) )+import GHC.IO.Handle ( hFlushAll )+import GHC.TopHandler ( topHandler )++import qualified GHC.Unit.Module.Graph as GHC+++-- clash additions+import Clash.Backend (Backend(initBackend, hdlKind, primDirs))+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import qualified Clash.Driver+import Clash.Driver.Bool (fromGhcOverridingBool)+import Clash.Driver.Types (ClashOpts(..), ClashEnv(..), ClashDesign(..))+import Clash.GHC.Evaluator+import Clash.GHC.GenerateBindings+import Clash.GHC.NetlistTypes+import Clash.GHC.PartialEval+import Clash.GHCi.Common+import Clash.GHCi.Leak+import Clash.GHCi.UI.Print+import Clash.Util (clashLibVersion, reportTimeDiff)+import Data.Proxy+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+ availableCommands :: [Command],+ fullHelpText :: String,+ defPrompt :: PromptFunction,+ defPromptCont :: PromptFunction+ }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+ GhciSettings {+ availableCommands = ghciCommands opts,+ defPrompt = default_prompt,+ defPromptCont = default_prompt_cont,+ fullHelpText = defFullHelpText+ }++ghciWelcomeMsg :: String+ghciWelcomeMsg =+ "Clashi, version " ++ Data.Version.showVersion Paths_clash_ghc.version +++ " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion +++ "):\nhttps://clash-lang.org/ :? for help"++ghciCommands :: IORef ClashOpts -> [Command]+ghciCommands opts = map mkCmd [+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap+ ("?", keepGoing help, noCompletion),+ ("add", keepGoingPaths addModule, completeFilename),+ ("abandon", keepGoing abandonCmd, noCompletion),+ ("break", keepGoing breakCmd, completeBreakpoint),+ ("back", keepGoing backCmd, noCompletion),+ ("browse", keepGoing' (browseCmd False), completeModule),+ ("browse!", keepGoing' (browseCmd True), completeModule),+ ("cd", keepGoing' changeDirectory, completeFilename),+ ("continue", keepGoing' continueCmd, noCompletion),+ ("cmd", keepGoing cmdCmd, completeExpression),+ ("def", keepGoing (defineMacro False), completeExpression),+ ("def!", keepGoing (defineMacro True), completeExpression),+ ("delete", keepGoing deleteCmd, noCompletion),+ ("disable", keepGoing disableCmd, noCompletion),+ ("doc", keepGoing' docCmd, completeIdentifier),+ ("edit", keepGoing' editFile, completeFilename),+ ("enable", keepGoing enableCmd, noCompletion),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoing help, noCompletion),+ ("history", keepGoing historyCmd, noCompletion),+ ("info", keepGoing' (info False), completeIdentifier),+ ("info!", keepGoing' (info True), completeIdentifier),+ ("issafe", keepGoing' isSafeCmd, completeModule),+ ("ignore", keepGoing ignoreCmd, noCompletion),+ ("kind", keepGoing' (kindOfType False), completeIdentifier),+ ("kind!", keepGoing' (kindOfType True), completeIdentifier),+ ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),+ ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),+ ("list", keepGoing' listCmd, noCompletion),+ ("module", keepGoing moduleCmd, completeSetModule),+ ("main", keepGoing runMain, completeFilename),+ ("print", keepGoing printCmd, completeExpression),+ ("quit", quit, noCompletion),+ ("reload", keepGoing' reloadModule, noCompletion),+ ("reload!", keepGoing' reloadModuleDefer, noCompletion),+ ("run", keepGoing' runRun, completeFilename),+ ("script", keepGoing' scriptCmd, completeFilename),+ ("set", keepGoing setCmd, completeSetOptions),+ ("seti", keepGoing setiCmd, completeSeti),+ ("show", keepGoing' showCmd, completeShowOptions),+ ("showi", keepGoing showiCmd, completeShowiOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepout", keepGoing stepOutCmd, noCompletion),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoing' typeOfExpr, completeExpression),+ ("trace", keepGoing traceCmd, completeExpression),+ ("unadd", keepGoingPaths unAddModule, completeFilename),+ ("undef", keepGoing undefineMacro, completeMacro),+ ("unset", keepGoing unsetOptions, completeSetOptions),+ ("where", keepGoing whereCmd, noCompletion),+ ("vhdl", keepGoingPaths (makeVHDL opts), completeHomeModuleOrFile),+ ("verilog", keepGoingPaths (makeVerilog opts), completeHomeModuleOrFile),+ ("systemverilog", keepGoingPaths (makeSystemVerilog opts), completeHomeModuleOrFile),+ ("instances", keepGoing' instancesCmd, completeExpression)+ ] ++ map mkCmdHidden [ -- hidden commands+ ("all-types", keepGoing' allTypesCmd),+ ("complete", keepGoing completeCmd),+ ("loc-at", keepGoing' locAtCmd),+ ("type-at", keepGoing' typeAtCmd),+ ("uses", keepGoing' usesCmd)+ ]+ where+ mkCmd (n,a,c) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = False+ , cmdCompletionFunc = c+ }++ mkCmdHidden (n,a) = Command { cmdName = n+ , cmdAction = a+ , cmdHidden = True+ , cmdCompletionFunc = noCompletion+ }++-- We initialize readline (in the interactiveUI function) to use+-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+--+-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = spaces ++ specials ++ symbols++word_break_chars_pred :: Char -> Bool+word_break_chars_pred '.' = False+word_break_chars_pred c = c `elem` (spaces ++ specials) || isSymbolChar c++symbols, specials, spaces :: String+symbols = "!#$%&*+/<=>?@\\^|-~"+specials = "(),;[]`{}"+spaces = " \t\n"++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++showSDocForUser' :: GHC.GhcMonad m => SDoc -> m String+showSDocForUser' doc = do+ dflags <- getDynFlags+ unit_state <- hsc_units <$> GHC.getSession+ name_ppr_ctx <- GHC.getNamePprCtx+ pure $ showSDocForUser dflags unit_state name_ppr_ctx doc++showSDocForUserQualify :: GHC.GhcMonad m => SDoc -> m String+showSDocForUserQualify doc = do+ dflags <- getDynFlags+ unit_state <- hsc_units <$> GHC.getSession+ pure $ showSDocForUser dflags unit_state alwaysQualify doc+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome+keepGoing' a str = do+ a str+ return CmdSuccess++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)+keepGoingPaths a str+ = do case toArgsNoLoc str of+ Left err -> reportError (GhciInvalidArgumentString err) >> return CmdSuccess+ Right args -> keepGoing' a args++defFullHelpText :: String+defFullHelpText =+ " Commands available from the prompt:\n" +++ "\n" +++ " <statement> evaluate/run <statement>\n" +++ " : repeat last command\n" +++ " :{\\n ..lines.. \\n:}\\n multiline command\n" +++ " :add [*]<module> ... add module(s) to the current target set\n" +++ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" +++ " (!: more details; *: all top-level names)\n" +++ " :cd <dir> change directory to <dir>\n" +++ " :cmd <expr> run the commands returned by <expr>::IO String\n" +++ " :complete <dom> [<rng>] <s> list completions for partial input string\n" +++ " :def[!] <cmd> <expr> define command :<cmd> (later defined command has\n" +++ " precedence, ::<cmd> is always a builtin command)\n" +++ " (!: redefine an existing command name)\n" +++ " :doc <name> display docs for the given name (experimental)\n" +++ " :edit <file> edit file\n" +++ " :edit edit last module\n" +++ " :help, :? display this list of commands\n" +++ " :info[!] [<name> ...] display information about the given names\n" +++ " (!: do not filter instances)\n" +++ " :instances <type> display the class instances available for <type>\n" +++ " :issafe [<mod>] display safe haskell information of module <mod>\n" +++ " :kind[!] <type> show the kind of <type>\n" +++ " (!: also print the normalised type)\n" +++ " :load[!] [*]<module> ... load module(s) and their dependents\n" +++ " (!: defer type errors)\n" +++ " :main [<arguments> ...] run the main function with the given arguments\n" +++ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" +++ " :quit exit GHCi\n" +++ " :reload[!] reload the current module set\n" +++ " (!: defer type errors)\n" +++ " :run function [<arguments> ...] run the function with the given arguments\n" +++ " :script <file> run the script <file>\n" +++ " :type <expr> show the type of <expr>\n" +++ " :type +d <expr> show the type of <expr>, defaulting type variables\n" +++ " :unadd <module> ... remove module(s) from the current target set\n" +++ " :undef <cmd> undefine user-defined command :<cmd>\n" +++ " ::<cmd> run the builtin command\n" +++ " :!<command> run the shell command <command>\n" +++ " :vhdl synthesize currently loaded module to vhdl\n" +++ " :vhdl [<module>] synthesize specified modules/files to vhdl\n" +++ " :verilog synthesize currently loaded module to verilog\n" +++ " :verilog [<module>] synthesize specified modules/files to verilog\n" +++ " :systemverilog synthesize currently loaded module to systemverilog\n" +++ " :systemverilog [<module>] synthesize specified modules/files to systemverilog\n" +++ "\n" +++ " -- Commands for debugging:\n" +++ "\n" +++ " :abandon at a breakpoint, abandon current computation\n" +++ " :back [<n>] go back in the history N steps (after :trace)\n" +++ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" +++ " :break <name> set a breakpoint on the specified function\n" +++ " :continue [<count>] resume after a breakpoint [and set break ignore count]\n" +++ " :delete <number> ... delete the specified breakpoints\n" +++ " :delete * delete all breakpoints\n" +++ " :disable <number> ... disable the specified breakpoints\n" +++ " :disable * disable all breakpoints\n" +++ " :enable <number> ... enable the specified breakpoints\n" +++ " :enable * enable all breakpoints\n" +++ " :force <expr> print <expr>, forcing unevaluated parts\n" +++ " :forward [<n>] go forward in the history N step s(after :back)\n" +++ " :history [<n>] after :trace, show the execution history\n" +++ " :ignore <breaknum> <count> for break <breaknum> set break ignore <count>\n" +++ " :list show the source code around current breakpoint\n" +++ " :list <identifier> show the source code for <identifier>\n" +++ " :list [<module>] <line> show the source code around line number <line>\n" +++ " :print [<name> ...] show a value without forcing its computation\n" +++ " :sprint [<name> ...] simplified version of :print\n" +++ " :step single-step after stopping at a breakpoint\n"+++ " :step <expr> single-step into <expr>\n"+++ " :steplocal single-step within the current top-level binding\n"+++ " :stepout stop at the first breakpoint after returning from the current scope\n"+++ " :stepmodule single-step restricted to the current module\n"+++ " :trace trace after stopping at a breakpoint\n"+++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++++ "\n" +++ " -- Commands for changing settings:\n" +++ "\n" +++ " :set <option> ... set options\n" +++ " :seti <option> ... set options for interactive evaluation only\n" +++ " :set local-config { source | ignore }\n" +++ " set whether to source .ghci in current dir\n" +++ " (loading untrusted config is a security issue)\n" +++ " :set args <arg> ... set the arguments returned by System.Environment.getArgs\n" +++ " :set prog <progname> set the value returned by System.Environment.getProgName\n" +++ " :set prompt <prompt> set the prompt used in GHCi\n" +++ " :set prompt-cont <prompt> set the continuation prompt used in GHCi\n" +++ " :set prompt-function <expr> set the function to handle the prompt\n" +++ " :set prompt-cont-function <expr>\n" +++ " set the function to handle the continuation prompt\n" +++ " :set editor <cmd> set the command used for :edit\n" +++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" +++ " :unset <option> ... unset options\n" +++ "\n" +++ " Options for ':set' and ':unset':\n" +++ "\n" +++ " +m allow multiline commands\n" +++ " +r revert top-level expressions after each evaluation\n" +++ " +s print timing/memory stats after each evaluation\n" +++ " +t print type after evaluation\n" +++ " +c collect type/location info after loading modules\n" +++ " -<flags> most GHC command line flags can also be set here\n" +++ " (eg. -v2, -XFlexibleInstances, etc.)\n" +++ " for GHCi-specific flags, see User's Guide,\n"+++ " Flag reference, Interactive-mode options\n" +++ "\n" +++ " -- Commands for displaying information:\n" +++ "\n" +++ " :show bindings show the current bindings made at the prompt\n" +++ " :show breaks show the active breakpoints\n" +++ " :show context show the breakpoint context\n" +++ " :show imports show the current imports\n" +++ " :show linker show current linker state\n" +++ " :show modules show the currently loaded modules\n" +++ " :show packages show the currently active package flags\n" +++ " :show paths show the currently active search paths\n" +++ " :show language show the currently active language flags\n" +++ " :show targets show the current set of targets\n" +++ " :show <setting> show value of <setting>, which is one of\n" +++ " [args, prog, editor, stop]\n" +++ " :showi language show language flags for interactive evaluation\n" +++ "\n" +++ " The User's Guide has more information. An online copy can be found here:\n" +++ "\n" +++ " https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci.html\n" +++ "\n"++findEditor :: IO String+findEditor = do+ getEnv "VISUAL" <|> getEnv "EDITOR" <|> defaultEditor+ where+ defaultEditor = do+#if defined(mingw32_HOST_OS)+ win <- System.Win32.getWindowsDirectory+ return (win </> "notepad.exe")+#else+ return ""+#endif++default_progname, default_stop :: String+default_progname = "<interactive>"+default_stop = ""++default_prompt, default_prompt_cont :: PromptFunction+default_prompt = generatePromptFunctionFromString "clashi> "+default_prompt_cont = generatePromptFunctionFromString "clashi| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String]+ -> Ghc ()+interactiveUI config srcs maybe_exprs = do+ -- HACK! If we happen to get into an infinite loop (eg the user+ -- types 'let x=x in x' at the prompt), then the thread will block+ -- on a blackhole, and become unreachable during GC. The GC will+ -- detect that it is unreachable and send it the NonTermination+ -- exception. However, since the thread is unreachable, everything+ -- it refers to might be finalized, including the standard Handles.+ -- This sounds like a bug, but we don't have a good solution right+ -- now.+ _ <- liftIO $ newStablePtr stdin+ _ <- liftIO $ newStablePtr stdout+ _ <- liftIO $ newStablePtr stderr++ -- Initialise buffering for the *interpreted* I/O system+ (nobuffering, flush) <- runInternal initInterpBuffering++ installInteractiveHomeUnits++ -- Update the LogAction. Ensure we don't override the user's log action lest+ -- we break -ddump-json (#14078)+ lastErrLocationsRef <- liftIO $ newIORef []+ pushLogHookM (ghciLogAction lastErrLocationsRef)++ when (isNothing maybe_exprs) $ do+ -- Only for GHCi (not runghc and ghc -e):++ -- Turn buffering off for the compiled program's stdout/stderr+ turnOffBuffering_ nobuffering+ -- Turn buffering off for GHCi's stdout+ liftIO $ hFlush stdout+ liftIO $ hSetBuffering stdout NoBuffering+ -- We don't want the cmd line to buffer any input that might be+ -- intended for the program, so unbuffer stdin.+ liftIO $ hSetBuffering stdin NoBuffering+ liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+ -- On Unix, stdin will use the locale encoding. The IO library+ -- doesn't do this on Windows (yet), so for now we use UTF-8,+ -- for consistency with GHC 6.10 and to make the tests work.+ liftIO $ hSetEncoding stdin utf8+#endif++ default_editor <- liftIO $ findEditor+ eval_wrapper <- mkEvalWrapper default_progname default_args+ let prelude_import =+ case simpleImportDecl preludeModuleName of+ -- Set to True because Prelude is implicitly imported.+ impDecl@ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}}+ empty_cache <- liftIO newIfaceCache+ startGHCi (runGHCi srcs maybe_exprs)+ GHCiState{ progname = default_progname,+ args = default_args,+ evalWrapper = eval_wrapper,+ prompt = defPrompt config,+ prompt_cont = defPromptCont config,+ stop = default_stop,+ editor = default_editor,+ options = [],+ localConfig = SourceLocalConfig,+ -- We initialize line number as 0, not 1, because we use+ -- current line number while reporting errors which is+ -- incremented after reading a line.+ line_number = 0,+ break_ctr = 0,+ breaks = IntMap.empty,+ tickarrays = emptyModuleEnv,+ internalBreaks = emptyModuleEnv,+ ghci_commands = availableCommands config,+ ghci_macros = [],+ last_command = Nothing,+ cmd_wrapper = (cmdSuccess =<<),+ cmdqueue = [],+ remembered_ctx = [],+ transient_ctx = [],+ extra_imports = [],+ prelude_imports = [prelude_import],+ ghc_e = isJust maybe_exprs,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering,+ ifaceCache = empty_cache+ }++ return ()++{-+Note [Multiple Home Units aware GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHCi supports multiple home units natively and as a first class citizen.+All GHCi sessions use a multiple home unit session and have at least three+home units:++1. A home unit for the ghci session prompt+2. A home unit for scripts (i.e., modules that are ':load'ed or ':add'ed.)+3. The home unit specified by the user.+3+. If the users themselves provides more than one home unit.++The first home unit is the "interactive-ghci" unit, called the 'interactiveGhciUnit'.+It contains the same 'DynFlags' that are used by the 'InteractiveContext' for+interactive evaluation of expressions.+This 'HomeUnitEnv' is only used on the prompt of GHCi, so we may refer to it as+"interactive-prompt" unit.+See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']+for discussing its role.++The second home unit is the "interactive-session", called 'interactiveSessionUnit'+which is used for loading Scripts into GHCi that are not 'Target's of any home unit,+via `:load` or `:add`.+This home unit is necessary, as we can't guess to which home unit the 'Target' should+be added.++Both of these "interactive" home units depend on all other 'HomeUnitEnv's that+are passed as arguments on the cli.+Additionally, the "interactive-ghci" unit depends on "interactive-session".++We always evaluate expressions in the context of the+"interactive-ghci" session.+Since "interactive-ghci" depends on all home units, we can import any 'Module'+from the other home units with ease.++As we have a clear 'HomeUnitGraph' hierarchy, we can set 'interactiveGhciUnitId'+as the active home unit for the full duration of the GHCi session.+In GHCi, we always set 'interactiveGhciUnitId' to be the currently active home unit.++=== Single Home Unit Case Diagram++ Example: ghci -this-unit-id main ...+ Equivalent to: ghci -unit @unitA++ ┌───────────────────┐ ┌─────────────────────┐+ │ Interactive Prompt│ │ Interactive Session │+ │ │───────►│ │+ │ interactive-ghci │ │ interactive-session │+ └────────┬──────────┘ └──────────┬──────────┘+ │ │+ └───────────────┬──────────────┘+ │+ │+ ┌────▼───┐+ │ Unit A │+ │ main │+ └────────┘+++=== Multi Home Unit Case Diagram++ Example: ghci -unit @unitA -unit @unitB -unit @unitC++ ┌───────────────────┐ ┌─────────────────────┐+ │ Interactive Prompt│ │ Interactive Session │+ │ │───────►│ │+ │ interactive-ghci │ │ interactive-session │+ └────────┬──────────┘ └──────────┬──────────┘+ │ │+ └───────────────┬──────────────┘+ │+ ┌─────────────┼─────────────┐+ ┌────▼───┐ ┌────▼───┐ ┌────▼───┐+ │ Unit A │ │ Unit B │ │ Unit C │+ │ a-0.0 │ │ b-0.0 │ │ c-0.0 │+ └────────┘ └────────┘ └────────┘++As we can see, this design scales to an arbitrary number of Home Units.++=== 'interactiveGhciUnit' Home Unit++The 'interactiveGhciUnit' home unit is used for storing the 'DynFlags' of+the interactive context.+There is considerable overlap with the 'InteractiveContext,+see Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']+for details.++The 'DynFlags' of the 'interactiveGhciUnit' can be modified by using `:seti`+commands in the GHCi session.++=== 'interactiveSessionUnit' Home Unit++The 'interactiveSessionUnit' home unit is used as a kitchen sink for Modules that+are not part of a home unit already.+When the user types ":load", it is not trivial to figure to which home unit the module+should be added to.+Especially, when there is more than home unit. Thus, we always ":load"ed modules+to this home unit.++The 'DynFlags' of the 'interactiveSessionUnit' can be modified via the ':set'+commands in the GHCi session.+-}++-- | Set up the multiple home unit session.+-- Installs a 'HomeUnitEnv' for the ghci-prompt and one for the ghci-session in the+-- current 'HscEnv'.+--+-- Installs the two home units 'interactiveGhciUnit' and 'interactiveSessionUnit', which+-- both depend on any other 'HomeUnitEnv' that is already present in the current+-- 'HomeUnitGraph'.+--+-- In other words, in each GHCi session, there are always at least three 'HomeUnitEnv's:+--+-- * 'interactiveGhciUnit'+-- * 'interactiveSessionUnit'+-- * 'mainUnit' (by default)+--+-- The 'interactiveGhciUnit' is the currently active unit, i.e. @hscActiveUnit hsc_env == 'interactiveGhciUnitId'@,+-- and it stays as the active unit for the entire duration of GHCi.+-- Within GHCi, you can rely on this property.+--+-- For motivation and design, see Note [Multiple Home Units aware GHCi]+installInteractiveHomeUnits :: GHC.GhcMonad m => m ()+installInteractiveHomeUnits = do+ logger <- getLogger+ hsc_env <- GHC.getSession+ -- The initial set of DynFlags used for interactive evaluation is the same+ -- as the global DynFlags, plus:+ -- * -XExtendedDefaultRules and+ -- * -XNoMonomorphismRestriction.+ -- See Note [Changing language extensions for interactive evaluation] #10857+ dflags <- getDynFlags+ let+ dflags0' =+ (xopt_set_unlessExplSpec LangExt.ExtendedDefaultRules xopt_set) .+ (xopt_set_unlessExplSpec LangExt.MonomorphismRestriction xopt_unset) $+ dflags+ -- Disable warnings about unused packages+ -- It doesn't matter for the interactive session.+ -- See Note [No unused package warnings for the interactive session]+ dflags0 = wopt_unset dflags0' Opt_WarnUnusedPackages++ -- Trivial '-package-id <uid>' flag+ homeUnitPkgFlag uid =+ ExposePackage+ (unitIdString uid)+ (UnitIdArg $ RealUnit (Definite uid))+ (ModRenaming False [])++ sessionUnitExposedFlag =+ homeUnitPkgFlag interactiveSessionUnitId++ -- Explicitly depends on all home units and 'sessionUnitExposedFlag'.+ -- Normalise the 'dflagsPrompt', as they will be used for 'ic_dflags'+ -- of the 'InteractiveContext'.+ -- See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']+ -- Additionally, we remove all 'importPaths', to avoid accidentally adding+ -- any 'Target's to this 'Unit'.+ dflagsPrompt <- GHC.normaliseInteractiveDynFlags logger $+ setHomeUnitId interactiveGhciUnitId $ dflags0+ { packageFlags =+ [ sessionUnitExposedFlag ] +++ [ homeUnitPkgFlag uid+ | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env+ , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv]+ , let uid = homeUnitId homeUnit+ ] +++ (packageFlags dflags0)+ , importPaths = []+ }++ let+ -- Explicitly depends on all current home units.+ -- Additionally, we remove all 'importPaths', to avoid accidentally adding+ -- any 'Target's to this 'Unit' that are not ':load'ed.+ dflagsSession =+ setHomeUnitId interactiveSessionUnitId $ dflags+ { packageFlags =+ [ homeUnitPkgFlag uid+ | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env+ , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv]+ , let uid = homeUnitId homeUnit+ ] +++ (packageFlags dflags)+ , importPaths = []+ }++ let+ cached_unit_dbs =+ concat+ . catMaybes+ . fmap homeUnitEnv_unit_dbs+ $ Foldable.toList+ $ hsc_HUG hsc_env++ all_unit_ids =+ S.insert interactiveGhciUnitId $+ S.insert interactiveSessionUnitId $+ hsc_all_home_unit_ids hsc_env++ ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids cached_unit_dbs+ ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids cached_unit_dbs+ let+ -- Setup up the HUG, install the interactive home units+ withInteractiveUnits =+ HUG.unitEnv_insert interactiveGhciUnitId ghciPromptUnit+ . HUG.unitEnv_insert interactiveSessionUnitId ghciSessionUnit++ -- Finish up the setup, install the new HUG and make the 'interactiveGhciUnitId'+ -- the active unit.+ modifySessionM (\env -> do+ -- Set the new HUG+ let newEnv0 = hscUpdateHUG withInteractiveUnits env+ -- Make sure the 'interactiveGhciUnitId' is active and 'hsc_dflags'+ -- are populated correctly.+ -- The 'interactiveGhciUnitId' will stay as the active unit within GHCi.+ let newEnv1 = hscSetActiveUnitId interactiveGhciUnitId newEnv0+ -- Use the 'DynFlags' of the 'interactiveGhciUnitId' for the 'InteractiveContext'.+ GHC.initialiseInteractiveDynFlags dflagsPrompt newEnv1+ )++ pure ()+ where+ setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv+ setupHomeUnitFor logger dflags all_home_units cached_unit_dbs = do+ (dbs,unit_state,home_unit,_mconstants) <-+ liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units+ hpt <- liftIO emptyHomePackageTable+ pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit))++reportError :: GhciMonad m => GhciCommandMessage -> m ()+reportError err = do+ printError err+ failIfExprEvalMode++{-+Note [Changing language extensions for interactive evaluation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHCi maintains two sets of options:++- The "loading options" apply when loading modules+- The "interactive options" apply when evaluating expressions and commands+ typed at the GHCi prompt.++The loading options are mostly created in ghc/Main.hs:main' from the command+line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options+are copied to the interactive options.++These interactive options (but not the loading options!) are supplemented+unconditionally by setting ExtendedDefaultRules ON and+MonomorphismRestriction OFF. The unconditional setting of these options+eventually overwrite settings already specified at the command line.++Therefore instead of unconditionally setting ExtendedDefaultRules and+NoMonomorphismRestriction for the interactive options, we use the function+'xopt_set_unlessExplSpec' to first check whether the extension has already+specified at the command line.++The ghci config file has not yet been processed.+-}++resetLastErrorLocations :: GhciMonad m => m ()+resetLastErrorLocations = do+ st <- getGHCiState+ liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction+ghciLogAction lastErrLocations old_log_action+ dflags msg_class srcSpan msg = do+ old_log_action dflags msg_class srcSpan msg+ case msg_class of+ MCDiagnostic SevError _reason _code -> case srcSpan of+ RealSrcSpan rsp _ -> modifyIORef lastErrLocations+ (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+ _ -> return ()+ _ -> return ()++-- | Takes a file name and prefixes it with the appropriate GHC appdir.+-- ~/.ghc (getAppUserDataDirectory) is used if it exists, or XDG directories+-- are used to respect the XDG specification.+-- As a migration strategy, currently we will only create new directories in+-- the appropriate XDG location.+getAppDataFile :: XdgDirectory -> FilePath -> IO (Maybe FilePath)+getAppDataFile xdgDir file = do+ xdgAppDir <-+ tryIO (getXdgDirectory xdgDir "clash") >>= \case+ Left _ -> pure Nothing+ Right dir -> flip catchIO (const $ pure Nothing) $ do+ createDirectoryIfMissing False dir+ pure $ Just dir+ appDir <-+ tryIO (getAppUserDataDirectory "clash") >>= \case+ Right dir ->+ doesDirectoryExist dir >>= \case+ True -> pure $ Just dir+ False -> pure xdgAppDir+ Left _ -> pure xdgAppDir+ pure $ appDir >>= \dir -> Just $ dir </> file++runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++ appDataCfg = liftIO $ getAppDataFile XdgConfig "clashi.conf"++ homeCfg = do+ liftIO $ tryIO (getEnv "HOME") >>= \case+ Right home -> pure $ Just $ home </> ".clashi"+ _ -> pure Nothing++ canonicalizePath' :: FilePath -> IO (Maybe FilePath)+ canonicalizePath' fp = liftM Just (canonicalizePath fp)+ `catchIO` \_ -> return Nothing++ sourceConfigFile :: FilePath -> GHCi ()+ sourceConfigFile file = do+ exists <- liftIO $ doesFileExist file+ when exists $ do+ either_hdl <- liftIO $ tryIO (openFile file ReadMode)+ case either_hdl of+ Left _e -> return ()+ -- NOTE: this assumes that runInputT won't affect the terminal;+ -- can we assume this will always be the case?+ -- This would be a good place for runFileInputT.+ Right hdl ->+ do runInputTWithPrefs defaultPrefs defaultSettings $+ runCommands $ fileLoop hdl+ liftIO (hClose hdl `catchIO` \_ -> return ())+ -- Don't print a message if this is really ghc -e (#11478).+ -- Also, let the user silence the message with -v0+ -- (the default verbosity in GHCi is 1).+ when (isNothing maybe_exprs && verbosity dflags > 0) $+ liftIO $ putStrLn ("Loaded Clashi configuration from " ++ file)++ --++ setGHCContextFromGHCiState++ processedCfgs <- if ignore_dot_ghci+ then pure []+ else do+ userCfgs <- do+ paths <- catMaybes <$> sequence [ appDataCfg, homeCfg ]+ checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths+ liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths++ localCfg <- do+ let path = ".clashi"+ ok <- liftIO $ checkFileAndDirPerms path+ if ok then liftIO $ canonicalizePath' path else pure Nothing++ mapM_ sourceConfigFile userCfgs+ -- Process the global and user .ghci+ -- (but not $CWD/.ghci or CLI args, yet)++ behaviour <- localConfig <$> getGHCiState++ processedLocalCfg <- case localCfg of+ Just path | path `notElem` userCfgs ->+ -- don't read .ghci twice if CWD is $HOME+ case behaviour of+ SourceLocalConfig -> localCfg <$ sourceConfigFile path+ IgnoreLocalConfig -> pure Nothing+ _ -> pure Nothing++ pure $ maybe id (:) processedLocalCfg userCfgs++ let arg_cfgs = reverse $ ghciScripts dflags+ -- -ghci-script are collected in reverse order+ -- We don't require that a script explicitly added by -ghci-script+ -- is owned by the current user. (#6017)++ mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs+ -- Dedup, and remove any configs we already processed.+ -- Importantly, if $PWD/.ghci was ignored due to configuration,+ -- explicitly specifying it does cause it to be processed.++ -- Perform a :reload for files given on the GHCi command line+ -- The appropriate targets will already be set+ -- When in -e mode, if the load fails then we want to stop+ -- immediately rather than going on to evaluate the expression.+ when (not (null paths)) $ do+ ok <- ghciHandle (\e -> do showException e; return Failed) $+ loadModule (if gopt Opt_GhciDoLoadTargets dflags then LoadTargets else DontLoadTargets) paths+ when (isJust maybe_exprs && failed ok) $+ liftIO (exitWith (ExitFailure 1))++ installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++ -- if verbosity is greater than 0, or we are connected to a+ -- terminal, display the prompt in the interactive loop.+ is_tty <- liftIO (hIsTerminalDevice stdin)+ let show_prompt = verbosity dflags > 0 || is_tty++ -- reset line number+ modifyGHCiState $ \st -> st{line_number=0}++ case maybe_exprs of+ Nothing ->+ do+ runGHCiExpressions+ ["default ((), [], Prelude.Integer, Prelude.Int, Prelude.Double, Prelude.String)"]+ -- enter the interactive loop+ runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+ Just exprs -> do+ -- just evaluate the expression we were given+ runGHCiExpressions exprs++ -- and finally, exit+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."++runGHCiExpressions :: [String] -> GHCi ()+runGHCiExpressions exprs = do+ enqueueCommands exprs+ let hdle e = do st <- getGHCiState+ -- flush the interpreter's stdout/stderr on exit (#3890)+ flushInterpBuffers+ -- Jump through some hoops to get the+ -- current progname in the exception text:+ -- <progname>: <exception>+ liftIO $ withProgName (progname st)+ $ topHandler e+ -- this used to be topHandlerFastExit, see #2228+ runInputTWithPrefs defaultPrefs defaultSettings $ do+ -- make `ghc -e` exit nonzero on failure, see #7962, #9916, #17560, #18441+ _ <- runCommands' hdle+ (Just $ hdle (toException $ ExitFailure 1) >> return ())+ (return Nothing)+ return ()++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+ dflags <- getDynFlags+ let ghciHistory = gopt Opt_GhciHistory dflags+ let localGhciHistory = gopt Opt_LocalGhciHistory dflags+ currentDirectory <- liftIO getCurrentDirectory++ histFile <- case (ghciHistory, localGhciHistory) of+ (True, True) -> pure $ Just $ currentDirectory </> ".clashi_history"+ (True, _) -> liftIO $ getAppDataFile XdgData "clashi_history"+ _ -> pure Nothing++ runInputT+ (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+ f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+ | is_tty = do+ prmpt <- if show_prompt then lift mkPrompt else return ""+ r <- getInputLine prmpt+ incrementLineNo+ return r+ | otherwise = do+ when show_prompt $ lift mkPrompt >>= liftIO . putStr+ fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else. I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "." always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+ file_ok <- checkPerms file+ -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+ -- print some confusing and useless warnings in some cases (e.g. in+ -- travis). Note that we can't add a test for this, as all ghci tests should+ -- run with -ignore-dot-ghci, which means we never get here.+ if file_ok then checkPerms (getDirectory file) else return False+ where+ getDirectory f = case takeDirectory f of+ "" -> "."+ d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+ handleIO (\_ -> return False) $ do+ st <- getFileStatus file+ me <- getRealUserID+ let mode = System.Posix.fileMode st+ ok = (fileOwner st == me || fileOwner st == 0) &&+ groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+ otherWriteMode /= mode `intersectFileModes` otherWriteMode+ unless ok $+ -- #8248: Improving warning to include a possible fix.+ putStrLn $ "*** WARNING: " ++ file +++ " is writable by someone else, IGNORING!" +++ "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+ return ok+#endif++incrementLineNo :: GhciMonad m => m ()+incrementLineNo = modifyGHCiState incLineNo+ where+ incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: GhciMonad m => Handle -> m (Maybe String)+fileLoop hdl = do+ l <- liftIO $ tryIO $ hGetLine hdl+ case l of+ Left e | isEOFError e -> return Nothing+ | -- as we share stdin with the program, the program+ -- might have already closed it, so we might get a+ -- handle-closed exception. We therefore catch that+ -- too.+ isIllegalOperation e -> return Nothing+ | InvalidArgument <- etype -> return Nothing+ | otherwise -> liftIO $ ioError e+ where etype = ioeGetErrorType e+ -- treat InvalidArgument in the same way as EOF:+ -- this can happen if the user closed stdin, or+ -- perhaps did getContents which closes stdin at+ -- EOF.+ Right l' -> do+ incrementLineNo+ return (Just l')++formatCurrentTime :: String -> IO String+formatCurrentTime format =+ getZonedTime >>= return . (formatTime defaultTimeLocale format)++getUserName :: IO String+getUserName = do+#if defined(mingw32_HOST_OS)+ getEnv "USERNAME"+ `catchIO` \e -> do+ putStrLn $ show e+ return ""+#else+ getLoginName+#endif++getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)+getInfoForPrompt = do+ st <- getGHCiState+ imports <- GHC.getContext+ resumes <- GHC.getResumeContext++ context_bit <-+ case resumes of+ [] -> return empty+ r:_ -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (brackets (ppr (GHC.resumeSpan r)) <> space)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (brackets (ppr (negate ix) <> char ':'+ <+> ppr pan) <> space)++ let+ dots | _:rs <- resumes, not (null rs) = text "... "+ | otherwise = empty++ rev_imports = reverse imports -- rightmost are the most recent++ myIdeclName :: ImportDecl GhcPs -> ModuleName+ myIdeclName d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString (moduleName m)) | IIModule m <- rev_imports] +++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]+ line = 1 + line_number st++ return (dots <> context_bit, modules_names, line)++-- | Takes a string, presumably following "%call", and tries to parse+-- a command and arguments in parentheses:+--+-- > parseCallEscape " (cmd arg1 arg2)rest" = Just ("cmd" :| ["arg1", "arg2"], "rest")+-- > parseCallEscape "( )rest" = Nothing+--+parseCallEscape :: String -> Maybe (NE.NonEmpty String, String)+parseCallEscape s = case dropWhile isSpace s of+ '(' : sinceOpen -> case span (/= ')') sinceOpen of+ (call, ')' : sinceClosed)+ | cmd : args <- words call -> Just (cmd NE.:| args, sinceClosed)+ _ -> Nothing+ _ -> Nothing++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+ case parseCallEscape xs of+ Nothing -> Just ("Incorrect %call syntax. " +++ "Should be %call(a command and arguments).")+ Just (_, afterClosed) -> checkPromptStringForErrors afterClosed+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs+checkPromptStringForErrors "" = Nothing++generatePromptFunctionFromString :: String -> PromptFunction+generatePromptFunctionFromString promptS modules_names line =+ processString promptS+ where+ processString :: String -> GHCi SDoc+ processString ('%':'s':xs) =+ liftM2 (<>) (return modules_list) (processString xs)+ where+ modules_list = hsep . map text . ordNub $ modules_names+ processString ('%':'l':xs) =+ liftM2 (<>) (return $ ppr line) (processString xs)+ processString ('%':'d':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%a %b %d"+ processString ('%':'t':xs) =+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"+ processString ('%':'T':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"+ processString ('%':'@':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%I:%M %P"+ processString ('%':'A':xs) = do+ liftM2 (<>) (liftM text formatted_time) (processString xs)+ where+ formatted_time = liftIO $ formatCurrentTime "%H:%M"+ processString ('%':'u':xs) =+ liftM2 (<>) (liftM text user_name) (processString xs)+ where+ user_name = liftIO $ getUserName+ processString ('%':'w':xs) =+ liftM2 (<>) (liftM text current_directory) (processString xs)+ where+ current_directory = liftIO $ getCurrentDirectory+ processString ('%':'o':xs) =+ liftM ((text os) <>) (processString xs)+ processString ('%':'a':xs) =+ liftM ((text arch) <>) (processString xs)+ processString ('%':'N':xs) =+ liftM ((text compilerName) <>) (processString xs)+ processString ('%':'V':xs) =+ liftM ((text $ showVersion compilerVersion) <>) (processString xs)+ processString ('%':'c':'a':'l':'l':xs) = do+ -- Input has just been validated by parseCallEscape+ let (cmd NE.:| args, afterClosed) = fromJust $ parseCallEscape xs+ respond <- do+ (code, out, err) <-+ liftIO $ readProcessWithExitCode cmd args ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ reportError (GhciPromptCallError err)+ return ""+ liftM ((text respond) <>) (processString afterClosed)+ processString ('%':'%':xs) =+ liftM ((char '%') <>) (processString xs)+ processString (x:xs) =+ liftM (char x <>) (processString xs)+ processString "" =+ return empty++mkPrompt :: GHCi String+mkPrompt = do+ st <- getGHCiState+ dflags <- getDynFlags+ (context, modules_names, line) <- getInfoForPrompt++ prompt_string <- (prompt st) modules_names line+ let prompt_doc = context <> prompt_string++ return (showSDoc dflags prompt_doc)++queryQueue :: GhciMonad m => m (Maybe String)+queryQueue = do+ st <- getGHCiState+ case cmdqueue st of+ [] -> return Nothing+ c:cs -> do setGHCiState st{ cmdqueue = cs }+ return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: GhciMonad m => Maybe String -> Bool -> m ()+installInteractivePrint Nothing _ = return ()+installInteractivePrint (Just ipFun) exprmode = do+ ok <- trySuccess $ do+ name NE.:| _ <- GHC.parseName ipFun+ modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+ in he{hsc_IC = new_ic})+ return Succeeded++ when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+ -> Maybe (GHCi ()) -- ^ Source error handler+ -> InputT GHCi (Maybe String)+ -> InputT GHCi ()+runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do+ b <- handle (\e -> case fromException e of+ Just UserInterrupt -> return $ Just False+ _ -> case fromException e of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other ->+ liftIO (Exception.throwIO e))+ (unmask $ runOneCommand eh gCmd)+ case b of+ Nothing -> return ()+ Just success -> do+ unless success $ maybe (return ()) lift sourceErrorHandler+ unmask $ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the command was unsuccessful. GHCi will continue in either case.+-- TODO: replace Bool with CmdExecOutcome+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+ -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+ -- run a previously queued command if there is one, otherwise get new+ -- input from user+ mb_cmd0 <- noSpace (lift queryQueue)+ mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+ case mb_cmd1 of+ Nothing -> return Nothing+ Just c -> do+ st <- getGHCiState+ ghciHandle (\e -> lift $ eh e >>= return . Just) $+ handleSourceError printErrorAndFail $+ handleGhciCommandError printErrorAndContinue $+ cmd_wrapper st $ doCommand c+ -- source error's are handled by runStmt+ -- is the handler necessary here?+ where+ printErrorAndFail err = do+ printGhciException err+ return $ Just False -- Exit ghc -e, but not GHCi++ printErrorAndContinue err = do+ printGhciCommandException err+ return $ Just False -- Exit ghc -e, but not GHCi++ noSpace q = q >>= maybe (return Nothing)+ (\c -> case removeSpaces c of+ "" -> noSpace q+ ":{" -> multiLineCmd q+ _ -> return (Just c) )+ multiLineCmd q = do+ st <- getGHCiState+ let p = prompt st+ setGHCiState st{ prompt = prompt_cont st }+ mb_cmd <- collectCommand q "" `MC.finally`+ modifyGHCiState (\st' -> st' { prompt = p })+ return mb_cmd+ -- we can't use removeSpaces for the sublines here, so+ -- multiline commands are somewhat more brittle against+ -- fileformat errors (such as \r in dos input on unix),+ -- we get rid of any extra spaces for the ":}" test;+ -- we also avoid silent failure if ":}" is not found;+ -- and since there is no (?) valid occurrence of \r (as+ -- opposed to its String representation, "\r") inside a+ -- ghci command, we replace any such with ' ' (argh:-(+ collectCommand q c = q >>=+ maybe (liftIO (ioError collectError))+ (\l->if removeSpaces l == ":}"+ then return (Just c)+ else collectCommand q (c ++ "\n" ++ map normSpace l))+ where normSpace '\r' = ' '+ normSpace x = x+ -- SDM (2007-11-07): is userError the one to use here?+ -- no+ collectError = userError "unterminated multiline command :{ .. :}"++ cmdOutcome :: CmdExecOutcome -> Maybe Bool+ cmdOutcome CleanExit = Nothing+ cmdOutcome CmdSuccess = Just True+ cmdOutcome CmdFailure = Just False++ -- | Handle a line of input+ doCommand :: String -> InputT GHCi CommandResult++ -- command+ doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do+ (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd+ return $ CommandComplete stmt' (cmdOutcome <$> result) stats++ -- haskell+ doCommand stmt = do+ -- if 'stmt' was entered via ':{' it will contain '\n's+ let stmt_nl_cnt = length [ () | '\n' <- stmt ]+ ml <- lift $ isOptionSet Multiline+ if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+ then do+ fst_line_num <- line_number <$> getGHCiState+ mb_stmt <- checkInputForLayout stmt gCmd+ case mb_stmt of+ Nothing -> return CommandIncomplete+ Just ml_stmt -> do+ -- temporarily compensate line-number for multi-line input+ (stats, result) <- runAndPrintStats runAllocs $ lift $+ runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+ return $+ CommandComplete ml_stmt (Just . runSuccess <$> result) stats+ else do -- single line input and :{ - multiline input+ last_line_num <- line_number <$> getGHCiState+ -- reconstruct first line num from last line num and stmt+ let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+ | otherwise = last_line_num -- single line input+ stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+ stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+ -- temporarily compensate line-number for multi-line input+ (stats, result) <- runAndPrintStats runAllocs $ lift $+ runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+ return $ CommandComplete stmt' (Just . runSuccess <$> result) stats++ -- runStmt wrapper for temporarily overridden line-number+ runStmtWithLineNum :: Int -> String -> SingleStep+ -> GHCi (Maybe GHC.ExecResult)+ runStmtWithLineNum lnum stmt step = do+ st0 <- getGHCiState+ setGHCiState st0 { line_number = lnum }+ result <- runStmt stmt step+ -- restore original line_number+ getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+ return result++ -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+ dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+ , all isSpace l0 = dropLeadingWhiteLines r+ | otherwise = s+++-- #4316+-- lex the input. If there is an unclosed layout context, request input+checkInputForLayout+ :: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)+checkInputForLayout stmt getStmt = do+ dflags' <- getDynFlags+ let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule+ st0 <- getGHCiState+ let buf' = stringToStringBuffer stmt+ loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+ pstate = Lexer.initParserState (initParserOpts dflags) buf' loc+ case Lexer.unP goToEnd pstate of+ (Lexer.POk _ False) -> return $ Just stmt+ _other -> do+ st1 <- getGHCiState+ let p = prompt st1+ setGHCiState st1{ prompt = prompt_cont st1 }+ mb_stmt <- ghciHandle (\ex -> case fromException ex of+ Just UserInterrupt -> return Nothing+ _ -> case fromException ex of+ Just ghce ->+ do liftIO (print (ghce :: GhcException))+ return Nothing+ _other -> liftIO (Exception.throwIO ex))+ getStmt+ modifyGHCiState (\st' -> st' { prompt = p })+ -- the recursive call does not recycle parser state+ -- as we use a new string buffer+ case mb_stmt of+ Nothing -> return Nothing+ Just str -> if str == ""+ then return $ Just stmt+ else do+ checkInputForLayout (stmt++"\n"++str) getStmt+ where goToEnd = do+ eof <- Lexer.nextIsEOF+ if eof+ then Lexer.activeContext+ else Lexer.lexer False return >> goToEnd++enqueueCommands :: GhciMonad m => [String] -> m ()+enqueueCommands cmds = do+ -- make sure we force any exceptions in the commands while we're+ -- still inside the exception handler, otherwise bad things will+ -- happen (see #10501)+ cmds `deepseq` return ()+ modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`.+runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)+runStmt input step = do+ dflags <- GHC.getInteractiveDynFlags+ let pflags = initParserOpts dflags+ -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`+ -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The+ -- declarations and statements are not affected.+ -- See Note [Deferred type errors in GHCi] in GHC.Tc.Module+ st <- getGHCiState+ let source = progname st+ let line = line_number st++ -- Add any LANGUAGE/OPTIONS_GHC pragmas we find.+ set_pragmas pflags (supportedLanguagePragmas dflags)++ if | GHC.isStmt pflags input -> do+ hsc_env <- GHC.getSession+ mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))+ case mb_stmt of+ Nothing ->+ -- empty statement / comment+ return (Just exec_complete)+ Just stmt ->+ run_stmt stmt++ -- Otherwise assume a declaration (or a list of declarations)+ -- and/or import(s) (#20473).+ -- Note: `GHC.isDecl` returns False on input like+ -- `data Infix a b = a :@: b; infixl 4 :@:`+ -- and should therefore not be used here.+ | otherwise -> do+ hsc_env <- GHC.getSession+ let !ic = hsc_IC hsc_env -- Bang-pattern to avoid space leaks+ setDumpFilePrefix ic+ -- `-ddump-to-file` must work for normal GHCi compilations /+ -- evaluations. (#17500)+ -- Use >>= \case instead of MonadFail desugaring to take into+ -- consideration `instance XXModule p = DataConCantHappen`.+ -- Tracked in #15681+ liftIO (hscParseModuleWithLocation hsc_env source line input) >>= \case+ HsModule { hsmodDecls = decls, hsmodImports = imports } -> do+ run_imports imports+ run_decls decls+ where+ exec_complete = GHC.ExecComplete (Right []) 0++ run_imports imports = mapM_ (addImportToContext . unLoc) imports++ set_pragmas pflags supported =+ let stringbuf = stringToStringBuffer input+ (_msgs, loc_opts) = Header.getOptions pflags supported stringbuf "<interactive>"+ opts = unLoc <$> loc_opts+ in setOptions opts++ run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)+ run_stmt stmt = do+ m_result <- GhciMonad.runStmt stmt input step+ case m_result of+ Nothing -> return Nothing+ Just result -> Just <$> afterRunStmt step result++ -- `x = y` (a declaration) should be treated as `let x = y` (a statement).+ -- The reason is because GHCi wasn't designed to support `x = y`, but then+ -- b98ff3 (#7253) added support for it, except it did not do a good job and+ -- caused problems like:+ --+ -- - not adding the binders defined this way in the necessary places caused+ -- `x = y` to not work in some cases (#12091).+ -- - some GHCi command crashed after `x = y` (#15721)+ -- - warning generation did not work for `x = y` (#11606)+ -- - because `x = y` is a declaration (instead of a statement) differences+ -- in generated code caused confusion (#16089)+ --+ -- Instead of dealing with all these problems individually here we fix this+ -- mess by just treating `x = y` as `let x = y`.+ run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)+ -- Only turn `FunBind` and `VarBind` into statements, other bindings+ -- (e.g. `PatBind`) need to stay as decls.+ run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt (locA l) bind)+ run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt (locA l) bind)+ -- Note that any `x = y` declarations below will be run as declarations+ -- instead of statements (e.g. `...; x = y; ...`)+ run_decls decls = do+ -- In the new IO library, read handles buffer data even if the Handle+ -- is set to NoBuffering. This causes problems for GHCi where there+ -- are really two stdin Handles. So we flush any bufferred data in+ -- GHCi's stdin Handle here (only relevant if stdin is attached to+ -- a file, otherwise the read buffer can't be flushed).+ _ <- liftIO $ tryIO $ hFlushAll stdin+ m_result <- GhciMonad.runDecls' decls+ forM m_result $ \result ->+ afterRunStmt step (GHC.ExecComplete (Right result) 0)++ mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs+ mk_stmt loc bind =+ let+ la = L (noAnnSrcSpan loc)+ la' = L (noAnnSrcSpan loc)+ in la (LetStmt noAnn (HsValBinds noAnn (ValBinds NoAnnSortKey [la' bind] [])))++ setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500+ setDumpFilePrefix ic = do+ dflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags dflags { dumpPrefix = modStr ++ "." }+ where+ modStr = moduleNameString $ moduleName $ icInteractiveModule $ ic++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: GhciMonad m => SingleStep {-^ Type of step we took just before -}+ -> GHC.ExecResult -> m GHC.ExecResult+afterRunStmt step run_result = do+ resumes <- GHC.getResumeContext+ case run_result of+ GHC.ExecComplete{..} ->+ case execResult of+ Left ex -> liftIO $ Exception.throwIO ex+ Right names -> do+ show_types <- isOptionSet ShowType+ when show_types $ printTypeOfNames names+ GHC.ExecBreak names mb_info+ | first_resume : _ <- resumes+ -> do mb_id_loc <- toBreakIdAndLocation mb_info+ let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+ if (null bCmd)+ then printStoppedAtBreakInfo first_resume names+ else enqueueCommands [bCmd]+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]+ return ()++ | otherwise -> resume step Nothing >>=+ afterRunStmt step >> return ()++ flushInterpBuffers+ withSignalHandlers $ do+ b <- isOptionSet RevertCAFs+ when b revertCAFs++ return run_result++runSuccess :: Maybe GHC.ExecResult -> Bool+runSuccess run_result+ | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True+ | otherwise = False++runAllocs :: Maybe GHC.ExecResult -> Maybe Integer+runAllocs m = do+ res <- m+ case res of+ GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)+ _ -> Nothing++toBreakIdAndLocation :: GhciMonad m+ => Maybe GHC.InternalBreakpointId -> m (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ st <- getGHCiState+ hug <- hsc_HUG <$> GHC.getSession+ brks <- liftIO $ readIModBreaks hug inf+ let bi = getBreakSourceId inf brks+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),+ breakId loc == bi ]++printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()+printStoppedAtBreakInfo res names = do+ printForUser =<< pprStopped res+ -- printTypeOfNames session names+ let namesSorted = sortBy compareNames names+ tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+ docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+ printForUserPartWay $ vcat docs++printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+compareNames = on compare getOccString S.<> on SrcLoc.leftmost_smallest getSrcSpan++printTypeOfName :: GHC.GhcMonad m => Name -> m ()+printTypeOfName n+ = do maybe_tything <- GHC.lookupName n+ case maybe_tything of+ Nothing -> return ()+ Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+specialCommand :: String -> InputT GHCi CmdExecOutcome+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)+specialCommand str = do+ let (cmd,rest) = break isSpace str+ maybe_cmd <- lookupCommand cmd+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do reportError (GhciUnknownCommand cmd)+ return CmdFailure+ NoLastCommand ->+ do reportError GhciNoLastCommandAvailable+ return CmdFailure++shellEscape :: MonadIO m => String -> m CmdExecOutcome+shellEscape str = liftIO $ do+ exitCode <- system str+ case exitCode of+ ExitSuccess -> return CmdSuccess+ ExitFailure _ -> return CmdFailure++lookupCommand :: GhciMonad m => String -> m (MaybeCommand)+lookupCommand "" = do+ st <- getGHCiState+ case last_command st of+ Just c -> return $ GotCommand c+ Nothing -> return NoLastCommand+lookupCommand str = do+ mc <- lookupCommand' str+ modifyGHCiState (\st -> st { last_command = mc })+ return $ case mc of+ Just c -> GotCommand c+ Nothing -> BadCommand++lookupCommand' :: GhciMonad m => String -> m (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+ macros <- ghci_macros <$> getGHCiState+ ghci_cmds <- ghci_commands <$> getGHCiState++ let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds++ let (str, xcmds) = case str' of+ ':' : rest -> (rest, []) -- "::" selects a builtin command+ _ -> (str', macros) -- otherwise include macros in lookup++ lookupExact s = find $ (s ==) . cmdName+ lookupPrefix s = find $ (s `isPrefixOptOf`) . cmdName++ -- hidden commands can only be matched exact+ builtinPfxMatch = lookupPrefix str ghci_cmds_nohide++ -- first, look for exact match (while preferring macros); then, look+ -- for first prefix match (preferring builtins), *unless* a macro+ -- overrides the builtin; see #8305 for motivation+ return $ lookupExact str xcmds <|>+ lookupExact str ghci_cmds <|>+ (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+ builtinPfxMatch <|>+ lookupPrefix str xcmds++-- This predicate is for prefix match with a command-body and+-- suffix match with an option, such as `!`.+-- The current implementation assumes only the `!` character+-- as the option delimiter.+-- See also #17345+isPrefixOptOf :: String -> String -> Bool+isPrefixOptOf s x = let (body, opt) = break (== '!') s+ in (body `isPrefixOf` x) && (opt `isSuffixOf` x)++getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])+getCallStackAtCurrentBreakpoint = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ interp <- hscInterp <$> GHC.getSession+ Just <$> liftIO (costCentreStackInfo interp (GHC.resumeCCS r))++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: MonadIO m => m () -> String -> m ()+noArgs m "" = m+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()+withSandboxOnly cmd this = do+ dflags <- getDynFlags+ if not (gopt Opt_GhciSandbox dflags)+ then printForUser (text cmd <+>+ text "is not supported with -fno-ghci-sandbox")+ else this++-----------------------------------------------------------------------------+-- :help++help :: GhciMonad m => String -> m ()+help _ = do+ txt <- long_help `fmap` getGHCiState+ liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: GhciMonad m => Bool -> String -> m ()+info _ "" = reportError (GhciCommandSyntaxError "info <thing-you-want-info-about>")+info allInfo s = handleSourceError printGhciException $ do+ forM_ (words s) $ \thing -> do+ sdoc <- infoThing allInfo thing+ rendered <- showSDocForUser' sdoc+ liftIO (putStrLn rendered)++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM (GHC.getInfo allInfo) names+ let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)+ (catMaybes (NE.toList mb_stuffs))+ return $ vcat (intersperse (text "") $ map pprInfo filtered)++ -- Filter out names whose parent is also there. Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filterOut has_parent xs+ where+ all_names = mkNameSet (map (getName . get_thing) xs)+ has_parent x = case tyThingParent_maybe (get_thing x) of+ Just p -> getName p `elemNameSet` all_names+ Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts, docs)+ = docs+ $$ pprTyThingInContextLoc thing+ $$ showFixity thing fixity+ $$ vcat (map GHC.pprInstance cls_insts)+ $$ vcat (map GHC.pprFamInst fam_insts)++-----------------------------------------------------------------------------+-- :main++runMain :: GhciMonad m => String -> m ()+runMain s = toArgsNoLocWithErrorHandler s (doWithMain . doWithArgs)+ where+ doWithMain fun = do+ dflags <- getDynFlags+ let main = fromMaybe "main" (mainFunIs dflags)+ handleSourceError printErrAndMaybeExit $ do+ -- doing this will prevent the main to run when it is not in scope+ -- this might seem useless, but it doesn't suggest other functions+ -- to be used, which is exactly what we want here. See #23996.+ _ <- GHC.parseName main++ -- Wrap the main function in 'void' to discard its value instead+ -- of printing it (#9086). See Haskell 2010 report Chapter 5.+ fun $ "Control.Monad.void (" ++ main ++ ")"+++++-----------------------------------------------------------------------------+-- :run++runRun :: GhciMonad m => String -> m ()+runRun s = case toCmdArgs s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: GhciMonad m => [String] -> String -> m ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++ show args ++ " (" ++ cmd ++ ")"]++{-+Akin to @Prelude.words@, but acts like the Bourne shell, treating+quoted strings as Haskell Strings, and also parses Haskell [String]+syntax.+-}++getCmd :: String -> Either String -- Error+ (String, String) -- (Cmd, Rest)+getCmd s = case break isSpace $ dropWhile isSpace s of+ ([], _) -> Left ("Couldn't find command in " ++ show s)+ res -> Right res++toCmdArgs :: String -> Either String -- Error+ (String, [String]) -- (Cmd, Args)+toCmdArgs s = case getCmd s of+ Left err -> Left err+ Right (cmd, s') -> case toArgsNoLoc s' of+ Left err -> Left err+ Right args -> Right (cmd, args)++-- wrapper around GHC.Parser.Header.toArgs, but without locations+toArgsNoLoc :: String -> Either String [String]+toArgsNoLoc str = map unLoc <$> toArgs fake_loc str+ where+ fake_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1+ -- this should never be seen, because it's discarded with the `map unLoc`++toArgsNoLocWithErrorHandler :: GhciMonad m => String -> ([String] -> m ()) -> m ()+toArgsNoLocWithErrorHandler str f = case toArgsNoLoc str of+ Left err -> reportError $ GhciInvalidArgumentString err+ Right ok -> f ok++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: GhciMonad m => String -> m ()+changeDirectory "" = do+ -- :cd on its own changes to the user's home directory+ either_dir <- liftIO $ tryIO getHomeDirectory+ case either_dir of+ Left _e -> return ()+ Right dir -> changeDirectory dir+changeDirectory dir = do+ graph <- GHC.getModuleGraph+ when (not (null $ GHC.mgModSummaries graph)) $+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+ -- delete defined breakpoints and clear the interface file cache (#1620)+ clearCaches+ setContextAfterLoad False Nothing+ GHC.workingDirectoryChanged+ dir' <- expandPath dir+ liftIO $ setCurrentDirectory dir'+ -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+ -- (this gives consistent behaviour with and without -fexternal-interpreter)+ interp <- hscInterp <$> GHC.getSession+ case interpInstance interp of+ ExternalInterp {} -> do+ fhv <- compileGHCiExpr $+ "System.Directory.setCurrentDirectory " ++ show dir'+ liftIO $ evalIO interp fhv+ _ -> pure ()++trySuccess :: GhciMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+ handleSourceError (\e -> do printErrAndMaybeExit e -- immediately exit fith failure if in ghc -e+ pure Failed) act++-----------------------------------------------------------------------------+-- :edit++editFile :: GhciMonad m => String -> m ()+editFile str =+ do file <- if null str then chooseEditFile else expandPath str+ st <- getGHCiState+ errs <- liftIO $ readIORef $ lastErrorLocations st+ let cmd = editor st+ when (null cmd)+ $ throwGhcException (CmdLineError "editor not set, use :set editor")+ lineOpt <- liftIO $ do+ let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)+ `catchIO` (\_ -> return False)++ curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+ return $ case curFileErrs of+ (_, line):_ -> " +" ++ show line+ _ -> ""+ let cmdArgs = ' ':(file ++ lineOpt)+ code <- liftIO $ system (cmd ++ cmdArgs)++ when (code == ExitSuccess)+ $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the dependency analysis fails+-- (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occurred during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHC.GhcMonad m => m String+chooseEditFile =+ do let hasFailed (GHC.ModuleNode _deps x) = fmap not $ isLoadedModuleNode x+ hasFailed _ = return False++ graph <- GHC.getModuleGraph+ failed_graph <-+ GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries' graph)+ let order g = flattenSCCs $ filterToposortToModules $+ GHC.topSortModuleGraph True g Nothing+ pick xs = case xs of+ x : _ -> GHC.ml_hs_file (GHC.moduleNodeInfoLocation x)+ _ -> Nothing++ case pick (order failed_graph) of+ Just file -> return file+ Nothing ->+ do targets <- GHC.getTargets+ case msum (map fromTarget targets) of+ Just file -> return file+ Nothing -> throwGhcException (CmdLineError "No files to edit.")++ where fromTarget GHC.Target { targetId = GHC.TargetFile f _ } = Just f+ fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()+defineMacro overwrite s+ | (':' : _) <- s = invalidStartError Colon+ | ('!' : _) <- s = invalidStartError ExclamationMark+ | otherwise = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then printForUser $ if null defined+ then "no macros defined"+ else "the following macros are defined" <> colon $$+ nest 2 (vcat (map ((bullet <+>) . text) defined))+ else do+ isCommand <- isJust <$> lookupCommand' macro_name++ let check_newname+ | macro_name `elem` defined = Just (GhciMacroAlreadyDefined macro_name)+ | isCommand = Just (GhciMacroOverwritesBuiltin macro_name)+ | otherwise = Nothing++ if | not overwrite, Just err <- check_newname -> reportError (GhciMacroError err)+ | otherwise -> do+ -- compile the expression+ handleSourceError printErrAndMaybeExit $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr definition+ -- > ghciStepIO . definition :: String -> IO String+ let stringTy :: LHsType GhcPs+ stringTy = nlHsTyVar NotPromoted stringTyCon_RDR+ ioM :: LHsType GhcPs -- AZ+ ioM = nlHsTyVar NotPromoted (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+ `mkHsApp` (nlHsPar expr)+ tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $+ nlHsFunTy stringTy ioM+ new_expr = L (getLoc expr) $ ExprWithTySig noAnn body tySig+ hv <- GHC.compileParsedExprRemote new_expr++ let newCmd = Command { cmdName = macro_name+ , cmdAction = lift . runMacro hv+ , cmdHidden = False+ , cmdCompletionFunc = noCompletion+ }++ -- later defined macros have precedence+ modifyGHCiState $ \s ->+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]+ in s { ghci_macros = newCmd : filtered }+ where invalidStartError = reportError . GhciMacroError . GhciMacroInvalidStart s++runMacro+ :: GhciMonad m+ => GHC.ForeignHValue -- String -> IO String+ -> String+ -> m CmdExecOutcome+runMacro fun s = do+ interp <- hscInterp <$> GHC.getSession+ str <- liftIO $ evalStringToIOString interp fun s+ enqueueCommands (lines str)+ return CmdSuccess+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: GhciMonad m => String -> m ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+ cmds <- ghci_macros <$> getGHCiState+ if (macro_name `notElem` map cmdName cmds)+ then reportError (GhciMacroError $ GhciMacroNotDefined macro_name)+ else do+ -- This is a tad racy but really, it's a shell+ modifyGHCiState $ \s ->+ s { ghci_macros = filter ((/= macro_name) . cmdName)+ (ghci_macros s) }+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: GhciMonad m => String -> m ()+cmdCmd str = handleSourceError printErrAndMaybeExit $ do+ step <- getGhciStepIO+ expr <- GHC.parseExpr str+ -- > ghciStepIO str :: IO String+ let new_expr = step `mkHsApp` expr+ hv <- GHC.compileParsedExprRemote new_expr++ interp <- hscInterp <$> GHC.getSession+ cmds <- liftIO $ evalString interp hv+ enqueueCommands (lines cmds)++-- | Generate a typed ghciStepIO expression+-- @ghciStepIO :: Ty String -> IO String@.+getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)+getGhciStepIO = do+ ghciTyConName <- GHC.getGHCiMonad+ let stringTy = nlHsTyVar NotPromoted stringTyCon_RDR+ ghciM = nlHsTyVar NotPromoted (getRdrName ghciTyConName) `nlHsAppTy` stringTy+ ioM = nlHsTyVar NotPromoted (getRdrName ioTyConName) `nlHsAppTy` stringTy+ body = nlHsVar (getRdrName ghciStepIoMName)+ tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $+ nlHsFunTy ghciM ioM+ return $ noLocA $ ExprWithTySig noAnn body tySig++-----------------------------------------------------------------------------+-- :doc++docCmd :: GhciMonad m => String -> m ()+docCmd "" = reportError (GhciCommandSyntaxError "doc <thing-you-want-docs-for>")+docCmd s = do+ -- TODO: Maybe also get module headers for module names+ names <- GHC.parseName s++ docs <- traverse (buildDocComponents s) names++ let sdocs = pprDocs (NE.toList docs)+ sdocs' = vcat (intersperse (text "") sdocs)+ sdoc <- showSDocForUser' sdocs'+ liftIO (putStrLn sdoc)++data DocComponents =+ DocComponents+ { docs :: Maybe [HsDoc GhcRn] -- ^ subject's haddocks+ , sigAndLoc :: Maybe SDoc -- ^ type signature + category + location+ , argDocs :: IntMap (HsDoc GhcRn) -- ^ haddocks for arguments+ }++buildDocComponents :: GHC.GhcMonad m => String -> Name -> m DocComponents+buildDocComponents str name = do+ mbThing <- GHC.lookupName name+ let sigAndLoc = sigAndLocDoc str <$> mbThing+ (docs, argDocs)+ <- either handleGetDocsFailure pure+ =<< GHC.getDocs name++ pure DocComponents{..}++-- | Produce output containing the type/kind signature, category, and definition+-- location of a TyThing.+sigAndLocDoc :: String -> TyThing -> SDoc+sigAndLocDoc str tyThing =+ let tyThingTyDoc :: TyThing -> SDoc+ tyThingTyDoc = \case+ AnId i -> pprSigmaType $ varType i+ AConLike (RealDataCon dc) -> pprSigmaType $ dataConDisplayType False dc+ AConLike (PatSynCon patSyn) -> pprPatSynType patSyn+ ATyCon tyCon -> pprSigmaType $ GHC.tyConKind tyCon+ ACoAxiom _ -> empty++ tyDoc = tyThingTyDoc tyThing+ sigDoc = text str <+> nest 2 (dcolon <+> tyDoc)+ comment =+ hsep [ char '\t' <> text "--"+ , pprTyThingCategory tyThing+ , text "defined" <+> pprNameDefnLoc (getName tyThing)+ ]+ in hang sigDoc 2 comment++pprDocs :: [DocComponents] -> [SDoc]+pprDocs docs+ | null nonEmptyDocs = pprDoc <$> take 1 docs+ -- elide <has no documentation> if there's at least one non-empty doc (#15784)+ | otherwise = pprDoc <$> nonEmptyDocs+ where+ empty DocComponents{docs = mb_decl_docs, argDocs = arg_docs}+ = maybe True null mb_decl_docs && null arg_docs+ nonEmptyDocs = filter (not . empty) docs++-- TODO: also print arg docs.+pprDoc :: DocComponents -> SDoc+pprDoc DocComponents{sigAndLoc = mb_sig_loc, docs = mb_decl_docs} =+ maybe+ (text "<has no documentation>")+ formatDoc+ mb_decl_docs+ where+ formatDoc doc =+ vcat [ fromMaybe empty mb_sig_loc -- print contextual info (#19055)+ , pprHsDocStrings $ map hsDocString doc+ ]++handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m a+handleGetDocsFailure no_docs = do+ dflags <- getDynFlags+ let msg = showPpr dflags no_docs+ throwGhcException $ case no_docs of+ NameHasNoModule {} -> Sorry msg+ NoDocsInIface {} -> InstallationError msg+ InteractiveName -> ProgramError msg++-----------------------------------------------------------------------------+-- :instances++instancesCmd :: String -> InputT GHCi ()+instancesCmd "" = reportError (GhciCommandSyntaxError "instances <type-you-want-instances-for>")+instancesCmd s = do+ handleSourceError printGhciException $ do+ ty <- GHC.parseInstanceHead s+ res <- GHC.getInstancesForType ty++ printForUser $ vcat $ map ppr res++-----------------------------------------------------------------------------+-- :load, :add, :unadd, :reload++-- these are mainly used for displaying a more informative response+data LoadType = Add !Int | Unadd !Int | Load | Reload | Check++isReload :: LoadType -> Bool+isReload Reload = True+isReload _ = False++-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets+-- '-fdefer-type-errors' again if it has not been set before.+wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a+wrapDeferTypeErrors load =+ MC.bracket+ (do+ -- Force originalHUG to avoid leaking the associated HscEnv+ !originalHUG <- hsc_HUG <$> GHC.getSession+ _ <- GHC.setProgramHUG (fmap deferTypeErrors originalHUG)+ return originalHUG)+ (\originalHUG ->+ -- Restore the old 'DynFlags' for each home unit.+ -- This makes sure that '-fdefer-type-errors' is unset again, iff it wasn't set before.+ modifySession (hscUpdateHUG (restoreOriginalDynFlags originalHUG)))+ (\_ -> load)+ where+ deferTypeErrors home_unit_env =+ home_unit_env+ { homeUnitEnv_dflags =+ setGeneralFlag' Opt_DeferTypeErrors (homeUnitEnv_dflags home_unit_env)+ }++ restoreOriginalDynFlags (HUG.UnitEnvGraph old) (HUG.UnitEnvGraph new) = HUG.UnitEnvGraph $+ M.unionWith (\b a ->+ a { homeUnitEnv_dflags = homeUnitEnv_dflags b+ })+ old new++loadModule :: GhciMonad m => LoadTargets -> [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag+loadModule loadTargets fs = do+ (_, result) <- runAndPrintStats (const Nothing) (loadModule' loadTargets fs)+ either (liftIO . Exception.throwIO) return result++-- | @:load@ command+loadModule_ :: GhciMonad m => [FilePath] -> m ()+loadModule_ fs = void $ loadModule LoadTargets (zip3 fs (repeat (Just interactiveSessionUnitId)) (repeat Nothing))++loadModuleDefer :: GhciMonad m => [FilePath] -> m ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++-- | How much to actually load.+-- Used to implement the `-fno-load-initial-targets` flag.+-- During GHCi startup, we check whether the flag is set and+-- invoke 'loadModule'' with 'DontLoadTargets'.+data LoadTargets+ = DontLoadTargets+ -- ^ Used when `-fno-load-initial-targets` is given+ | LoadTargets+ -- ^ The Default+ deriving (Show, Eq, Ord)++loadModule' :: GhciMonad m => LoadTargets -> [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag+loadModule' loadTargets files = do+ let (filenames, uids, phases) = unzip3 files+ exp_filenames <- mapM expandPath filenames+ let files' = zip3 exp_filenames uids phases+ targets <- mapM (\(file, uid, phase) -> GHC.guessTarget file uid phase) files'++ -- NOTE: we used to do the dependency anal first, so that if it+ -- fails we didn't throw away the current set of modules. This would+ -- require some re-working of the GHC interface, so we'll leave it+ -- as a ToDo for now.++ hsc_env <- GHC.getSession+ let !dflags = hsc_dflags hsc_env++ let load_module = do+ -- unload first+ _ <- GHC.abandonAll+ clearCaches++ GHC.setTargets targets+ case loadTargets of+ LoadTargets -> doLoadAndCollectInfo Load LoadAllTargets+ DontLoadTargets -> doLoadAndCollectInfo Load (LoadUpTo [])++ if gopt Opt_GhciLeakCheck dflags+ then do+ -- Grab references to the currently loaded modules so that we can see if+ -- they leak.+ leak_indicators <- liftIO $ getLeakIndicators hsc_env+ success <- load_module+ liftIO $ checkLeakIndicators dflags leak_indicators+ return success+ else+ load_module++-- | @:add@ command+addModule :: GhciMonad m => [FilePath] -> m ()+addModule files = do+ revertCAFs -- always revert CAFs on load/add.+ files' <- mapM expandPath files+ -- New targets are always added to the 'interactiveSessionUnitId' 'HomeUnitEnv'.+ targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files'+ targets' <- filterM checkTarget targets+ -- remove old targets with the same id; e.g. for :add *M+ mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets' ]+ mapM_ GHC.addTarget targets'+ _ <- doLoadAndCollectInfo (Add $ length targets') LoadAllTargets+ return ()+ where+ checkTarget :: GhciMonad m => Target -> m Bool+ checkTarget Target { targetId = TargetModule m } = checkTargetModule m+ checkTarget Target { targetId = TargetFile f _ } = checkTargetFile f++ checkTargetModule :: GhciMonad m => ModuleName -> m Bool+ checkTargetModule m = do+ hsc_env <- GHC.getSession+ let home_unit = hsc_home_unit hsc_env+ result <- liftIO $+ Finder.findImportedModule hsc_env m (ThisPkg (homeUnitId home_unit))+ case result of+ Found _ _ -> return True+ _ -> do reportError (GhciModuleError $ GhciModuleNotFound (moduleNameString m))+ return False++ checkTargetFile :: GhciMonad m => String -> m Bool+ checkTargetFile f = do+ exists <- liftIO (doesFileExist f)+ unless exists $ reportError (GhciFileNotFound f)+ return exists++-- | @:unadd@ command+unAddModule :: GhciMonad m => [FilePath] -> m ()+unAddModule files = do+ files' <- mapM expandPath files+ -- New targets are always added to the 'interactiveSessionUnitId' 'HomeUnitEnv'.+ targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files'+ let removals = [ tid | Target { targetId = tid } <- targets ]+ mapM_ GHC.removeTarget removals+ _ <- doLoadAndCollectInfo (Unadd $ length removals) LoadAllTargets+ return ()++-- | @:reload@ command+reloadModule :: GhciMonad m => String -> m ()+reloadModule m = do+ let mods = words m+ loadTarget <- findLoadTargets mods+ ok <- doLoadAndCollectInfo Reload loadTarget+ when (failed ok) failIfExprEvalMode+ where+ findLoadTargets modls+ | null modls =+ pure LoadAllTargets+ | modls == ["none"] =+ -- "none" is a special targets that unloads all already loaded modules+ pure $ LoadUpTo []+ | otherwise = do+ mod_graph <- GHC.getModuleGraph+ mods <- traverse (lookupHomeUnitModuleName mod_graph) [mkModuleName modl | modl <- modls]+ pure $ LoadUpTo mods++reloadModuleDefer :: GhciMonad m => String -> m ()+reloadModuleDefer = wrapDeferTypeErrors . reloadModule++-- | Load/compile targets and (optionally) collect module-info+--+-- This collects the necessary SrcSpan annotated type information (via+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,+-- and @:uses@ commands.+--+-- Meta-info collection is not enabled by default and needs to be+-- enabled explicitly via @:set +c@. The reason is that collecting+-- the type-information for all sub-spans can be quite expensive, and+-- since those commands are designed to be used by editors and+-- tooling, it's useless to collect this data for normal GHCi+-- sessions.+doLoadAndCollectInfo :: GhciMonad m => LoadType -> LoadHowMuch -> m SuccessFlag+doLoadAndCollectInfo load_type howmuch = do+ doCollectInfo <- isOptionSet CollectInfo++ doLoad load_type howmuch >>= \case+ Succeeded | doCollectInfo -> do+ mod_summaries <- GHC.mgModSummaries <$> getModuleGraph+ loaded <- filterM GHC.isLoadedHomeModule (map ms_mod mod_summaries)+ v <- mod_infos <$> getGHCiState+ !newInfos <- collectInfo v loaded+ modifyGHCiState (\st -> st { mod_infos = newInfos })+ pure Succeeded+ flag -> pure flag++doLoad :: GhciMonad m => LoadType -> LoadHowMuch -> m SuccessFlag+doLoad load_type howmuch = do+ -- turn off breakpoints before we load: we can't turn them off later, because+ -- the ModBreaks will have gone away.+ discardActiveBreakPoints++ resetLastErrorLocations+ -- Enable buffering stdout and stderr as we're compiling. Keeping these+ -- handles unbuffered will just slow the compilation down, especially when+ -- compiling in parallel.+ let setBuffering t = liftIO $ do+ hSetBuffering stdout t+ hSetBuffering stderr t+ MC.bracket_ (setBuffering LineBuffering) (setBuffering NoBuffering) $ do+ hmis <- ifaceCache <$> getGHCiState+ -- If GHCi message gets its own configuration at some stage then this will need to be+ -- modified to 'embedUnknownDiagnostic'.+ ok <- trySuccess $ GHC.loadWithCache (Just hmis) (UnknownDiagnostic fromGhcOpts toGhcHint . GhciGhcMessage) howmuch+ afterLoad ok load_type+ pure ok++++afterLoad+ :: GhciMonad m+ => SuccessFlag+ -> LoadType+ -> m ()+afterLoad ok load_type = do+ revertCAFs -- always revert CAFs on load.+ discardTickArrays+ loaded_mods <- getLoadedModules+ modulesLoadedMsg ok loaded_mods load_type+ graph <- GHC.getModuleGraph+ setContextAfterLoad (isReload load_type) (Just graph)++setContextAfterLoad :: GhciMonad m => Bool -> Maybe GHC.ModuleGraph -> m ()+setContextAfterLoad keep_ctxt Nothing = do+ setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt (Just graph) = do+ -- load a target if one is available, otherwise load the topmost module.+ targets <- GHC.getTargets+ loaded_graph <- filterM is_loaded $ GHC.mgModSummaries' graph+ case [ m | Just m <- map (findTarget loaded_graph) targets ] of+ [] ->+ let graph' = flattenSCCs $ filterToposortToModules $+ GHC.topSortModuleGraph True (GHC.mkModuleGraph loaded_graph) Nothing+ in case graph' of+ [] -> setContextKeepingPackageModules keep_ctxt []+ xs -> load_this (last xs)+ (m:_) ->+ load_this m+ where+ is_loaded (GHC.ModuleNode _ ms) = isLoadedModuleNode ms+ is_loaded _ = return False++ findTarget mds t+ = case mapMaybe (`matches` t) mds of+ [] -> Nothing+ (m:_) -> Just m++ (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetModule m }+ = if GHC.moduleNodeInfoModuleName summary == m then Just summary else Nothing+ (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetFile f _ }+ | Just f' <- GHC.ml_hs_file (GHC.moduleNodeInfoLocation summary) =+ if f == f' then Just summary else Nothing+ _ `matches` _ = Nothing++ load_this summary | m <- GHC.moduleNodeInfoModule summary = do+ is_interp <- GHC.moduleIsInterpreted m+ dflags <- getDynFlags+ let star_ok = is_interp && not (safeLanguageOn dflags)+ -- We import the module with a * iff+ -- - it is interpreted, and+ -- - -XSafe is off (it doesn't allow *-imports)+ let new_ctx | star_ok = [mkIIModule m]+ | otherwise = [mkIIDecl (GHC.moduleName m)]+ setContextKeepingPackageModules keep_ctxt new_ctx+++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+ :: GhciMonad m+ => Bool -- True <=> keep all of remembered_ctx+ -- False <=> just keep package imports+ -> [InteractiveImport] -- new context+ -> m ()+setContextKeepingPackageModules keep_ctx trans_ctx = do++ st <- getGHCiState+ let rem_ctx = remembered_ctx st+ new_rem_ctx <- if keep_ctx then return rem_ctx+ else keepPackageImports rem_ctx+ setGHCiState st{ remembered_ctx = new_rem_ctx,+ transient_ctx = filterSubsumed new_rem_ctx trans_ctx }+ setGHCContextFromGHCiState++-- | Filters a list of 'InteractiveImport', clearing out any home package+-- imports so only imports from external packages are preserved. ('IIModule'+-- counts as a home package import, because we are only able to bring a+-- full top-level into scope when the source is available.)+keepPackageImports+ :: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]+keepPackageImports = filterM is_pkg_import+ where+ is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool+ is_pkg_import (IIModule _) = return False+ is_pkg_import (IIDecl d)+ = do pkgqual <- GHC.renameRawPkgQualM mod_name (ideclPkgQual d)+ e <- MC.try $ GHC.findQualifiedModule pkgqual mod_name+ hug <- hsc_HUG <$> GHC.getSession+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return $ not (HUG.memberHugUnit (moduleUnit m) hug)+ where+ mod_name = unLoc (ideclName d)++{- Note [GHCi and local Preludes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's compilation manager has no issues when the package being compiled+defines its own local Prelude module. It'll just shadow the Prelude from base.++GHCi however must check this condition, when it calls setContext ["Prelude"]+to prepopulate the interactive session's scope. This is because of two facts.++1. setContext must use previously compiled .hi interfaces only; it cannot+recurse into compiling .hs modules (even with LinkIntoMemory), simply because+it's not the right phase to do it. Import resolution happens way before GHC+properly "loads" modules (GHC.Linker.Loader.loadModule, GHC.load & siblings);+or in other words, at time of setContext the linker isn't even initialized yet.++2. The local Prelude.hs (or .lhs) may've never been compiled before, so its+interface file Prelude.hi can be outdated or altogether missing.++Thankfully, there's a simple solution: just let CM load the local Prelude normally+(either as a :load target, or as a dependency of another target) later. To do that,+detect if the implicit `import Prelude` resolves to the "home unit" (i.e. not base),+and if so, omit it from the early setContext call.++If we don't, a HomeModError will be (correctly) thrown. See #10920.+-}++modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModuleNodeInfo] -> LoadType -> m ()+modulesLoadedMsg ok mods load_type = do+ dflags <- getDynFlags+ when (verbosity dflags > 0) $ do+ mod_names <- mapM mod_name mods+ rendered_msg <- showSDocForUser' $+ if gopt Opt_ShowLoadedModules dflags+ then loaded_msg mod_names+ else msg+ liftIO $ putStrLn rendered_msg+ where+ num_mods = length mods+ none_loaded = num_mods == 0++ loaded_msg names =+ let mod_commas+ | null mods = text "none."+ | otherwise = hsep (punctuate comma names) <> text "."+ in status <> text ", modules loaded:" <+> mod_commas++ msg = status <> comma <+> msg' <> dot+ msg' = case load_type of+ Reload -> if none_loaded+ then "no modules to be reloaded"+ else n_mods num_mods "reloaded"+ Load -> if none_loaded+ then "unloaded all modules"+ else n_mods num_mods "loaded"+ Check -> n_mods 1 "checked"+ Add n -> n_mods n "added"+ Unadd n -> n_mods n "unadded"+ n_mods amount action = speakNOf amount "module" <+> action++ status | Succeeded <- ok = "Ok"+ | otherwise = "Failed"++ mod_name mod = do+ is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable (GHC.moduleNodeInfoModule mod)+ pure $ if is_interpreted+ then ppr (GHC.moduleNodeInfoModule mod)+ else ppr (GHC.moduleNodeInfoModule mod)+ <+> parens (text $ normalise $ (ml_obj_file (GHC.moduleNodeInfoLocation mod)))+ -- Fix #9887++-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors+-- and printing 'throwE' strings to 'stderr'. If in expression+-- evaluation mode - throw GhcException and exit.+runExceptGhciMonad :: GhciMonad m => ExceptT GhciCommandMessage m () -> m ()+runExceptGhciMonad act = handleSourceError printGhciException $+ either reportError pure =<<+ runExceptT act++-- | Inverse of 'runExceptT' for \"pure\" computations+-- (c.f. 'except' for 'Except')+exceptT :: Applicative m => Either e a -> ExceptT e m a+exceptT = ExceptT . pure++makeHDL'+ :: forall backend+ . Backend backend+ => Proxy backend+ -> IORef ClashOpts+ -> [FilePath]+ -> InputT GHCi ()+makeHDL' backend opts lst = go =<< case lst of+ srcs@(_:_) -> return srcs+ [] -> do+ modGraph <- GHC.getModuleGraph+ let sortedGraph =+ -- TODO: this might break backpack+ filterToposortToModules $+ GHC.topSortModuleGraph False modGraph Nothing+ return $ case (reverse sortedGraph) of+ ((AcyclicSCC (GHC.ModuleNodeCompile top)) : _) ->+ maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top+ _ -> []+ where+ go srcs = do+ logger <- getLogger+ dflags <- GHC.getSessionDynFlags+ goX logger dflags srcs `MC.finally` recover dflags++ goX logger dflags srcs = do+ -- Issue #439 step 1+ (dflagsX,_,_) <- DynFlags.parseDynamicFlagsCmdLine logger dflags+ [ noLoc "-fobject-code" -- For #439+ , noLoc "-fforce-recomp" -- Actually compile to object-code+ , noLoc "-keep-tmp-files" -- To prevent linker errors from+ -- multiple calls to :hdl command+ ]+ _ <- GHC.setSessionDynFlags dflagsX+ reloadModule ""+ -- Issue #439 step 2+ -- Unload any object files+ -- This fixes: https://github.com/clash-lang/clash-compiler/issues/439#issuecomment-522015868+ env <- GHC.getSession+ liftIO (Loader.unload (hscInterp env) env [])+ -- Finally generate the HDL+ makeHDL backend (return ()) opts srcs++ recover dflags = do+ _ <- GHC.setSessionDynFlags dflags+ reloadModule ""++makeHDL+ :: forall backend m+ . (GHC.GhcMonad m, Backend backend)+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [FilePath]+ -> m ()+makeHDL Proxy startAction optsRef srcs = do+ -- Validate every target before loading or synthesizing any of them.+ mapM_ (\src -> GHC.guessTarget src Nothing Nothing) srcs+ dflags <- GHC.getSessionDynFlags+ liftIO $ do startTime <- Clock.getCurrentTime+ opts0 <- readIORef optsRef+ let opts1 = opts0 { opt_color = fromGhcOverridingBool (useColor dflags) }+ let iw = opt_intWidth opts1+ hdl = hdlKind backend+ -- determine whether `-outputdir` was used+ outputDir = do odir <- objectDir dflags+ hidir <- hiDir dflags+ sdir <- stubDir dflags+ ddir <- dumpDir dflags+ if all (== odir) [hidir,sdir,ddir]+ then Just odir+ else Nothing+ idirs = importPaths dflags+ opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)+ , opt_importPaths = idirs}+ backend = initBackend @backend opts2++ checkMonoLocalBinds dflags+ checkImportDirs opts0 idirs++ primDirs_ <- primDirs backend++ forM_ srcs $ \src -> do+ -- Generate bindings:+ let dbs = reverse [p | PackageDB (PkgDbPath p) <- packageDBFlags dflags]+ (clashEnv, clashDesign) <- generateBindings opts2 startAction primDirs_ idirs dbs hdl src (Just dflags)++ let getMain = getMainTopEntity src clashDesign+ mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)+ prepTime <- startTime `deepseq` designBindings clashDesign `deepseq` envTyConMap clashEnv `deepseq` Clock.getCurrentTime+ let prepStartDiff = reportTimeDiff prepTime startTime+ putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff++ -- Generate HDL:+ Clash.Driver.generateHDL+ clashEnv+ clashDesign+ (Just backend)+ (ghcTypeToHWType iw)+ ghcEvaluator+ evaluator+ mainTopEntity+ startTime++makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVHDL = makeHDL' (Proxy @VHDLState)++makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVerilog = makeHDL' (Proxy @VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState)++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.++typeOfExpr :: GhciMonad m => String -> m ()+typeOfExpr str = handleSourceError printErrAndMaybeExit $+ case break isSpace str of+ ("+v", _) -> printForUser (text "`:type +v' has gone; use `:type' instead")+ ("+d", rest) -> do_it GHC.TM_Default (dropWhile isSpace rest)+ _ -> do_it GHC.TM_Inst str+ where+ do_it mode expr_str+ = do { ty <- GHC.exprType mode expr_str+ ; printForUser $ sep [ text expr_str+ , nest 2 (dcolon <+> pprSigmaType ty)] }++withModuleError :: Functor m => ExceptT GhciModuleError m a -> ExceptT GhciCommandMessage m a+withModuleError = withExceptT GhciModuleError++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: GhciMonad m => String -> m ()+typeAtCmd str = runExceptGhciMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ (info, ty) <- withModuleError $ findType infos span' sample+ let mb_rdr_env = Just (modinfoRdrEnv info)+ lift $ printForUserGlobalRdrEnv+ mb_rdr_env+ (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: GhciMonad m => String -> m ()+usesCmd str = runExceptGhciMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ uses <- withModuleError $ findNameUses infos span' sample+ forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: GhciMonad m => String -> m ()+locAtCmd str = runExceptGhciMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ (_,_,sp) <- withModuleError $ findLoc infos span' sample+ liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: GhciMonad m => String -> m ()+allTypesCmd _ = runExceptGhciMonad $ do+ infos <- lift $ mod_infos <$> getGHCiState+ forM_ (M.elems infos) $ \mi ->+ forM_ (modinfoSpans mi) (lift . printSpan)+ where+ printSpan span'+ | Just ty <- spaninfoType span' = do+ tyInfo <- (unwords . words) <$>+ showSDocForUserQualify (pprSigmaType ty)+ liftIO . putStrLn $+ showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo+ | otherwise = return ()++-----------------------------------------------------------------------------+-- Helpers for locAtCmd/typeAtCmd/usesCmd++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpanArg :: String -> Either GhciCommandMessage (RealSrcSpan,String)+parseSpanArg s = do+ (fp,s0) <- readAsString (skipWs s)+ s0' <- skipWs1 s0+ (sl,s1) <- readAsInt s0'+ s1' <- skipWs1 s1+ (sc,s2) <- readAsInt s1'+ s2' <- skipWs1 s2+ (el,s3) <- readAsInt s2'+ s3' <- skipWs1 s3+ (ec,s4) <- readAsInt s3'++ trailer <- case s4 of+ [] -> Right ""+ _ -> skipWs1 s4++ let fs = mkFastString fp+ span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)+ -- End column of RealSrcSpan is the column+ -- after the end of the span.+ (mkRealSrcLoc fs el (ec + 1))++ return (span',trailer)+ where+ readAsInt :: String -> Either GhciCommandMessage (Int,String)+ readAsInt "" = failParse "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> failParse $ "Couldn't read" <+> text (show s0) <+> "as Int"++ readAsString :: String -> Either GhciCommandMessage (String,String)+ readAsString s0+ | '"':_ <- s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> leftRes+ | s_rest@(_:_,_) <- breakWs s0 = Right s_rest+ | otherwise = leftRes+ where+ leftRes = failParse $ "Couldn't read" <+> text (show s0) <+> "as String"++ skipWs1 :: String -> Either GhciCommandMessage String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = failParse $ "Expected whitespace in" <+> text (show s0)++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+ failParse = Left . GhciArgumentParseError+++-- | Pretty-print \"real\" 'SrcSpan's as+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@+-- while simply unpacking 'UnhelpfulSpan's+showSrcSpan :: SrcSpan -> String+showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s)+showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn++-- | Variant of 'showSrcSpan' for 'RealSrcSpan's+showRealSrcSpan :: RealSrcSpan -> String+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc+ , ")-(", show el, ",", show ec, ")"+ ]+ where+ fp = unpackFS (srcSpanFile spn)+ sl = srcSpanStartLine spn+ sc = srcSpanStartCol spn+ el = srcSpanEndLine spn+ -- The end column is the column after the end of the span see the+ -- RealSrcSpan module+ ec = let ec' = srcSpanEndCol spn in if ec' == 0 then 0 else ec' - 1++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: GhciMonad m => Bool -> String -> m ()+kindOfType norm str = handleSourceError printErrAndMaybeExit $ do+ (ty, kind) <- GHC.typeKind norm str+ printForUser $ vcat [ text str <+> dcolon <+> pprSigmaType kind+ , ppWhen norm $ equals <+> pprSigmaType ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: Monad m => String -> m CmdExecOutcome+quit _ = return CleanExit+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+ case words' ws of+ [s] -> runScript s+ _ -> reportError (GhciCommandSyntaxError "script <filename>")++-- | A version of 'words' that treats sequences enclosed in double quotes as+-- single words and that does not break on backslash-escaped spaces.+-- E.g., 'words\' "\"lorem ipsum\" dolor"' and 'words\' "lorem\\ ipsum dolor"'+-- yield '["lorem ipsum", "dolor"]'.+-- Used to scan for file paths in 'scriptCmd'.+words' :: String -> [String]+words' s = case dropWhile isSpace s of+ "" -> []+ s'@('\"' : _) | [(w, s'')] <- reads s' -> w : words' s''+ s' -> go id s'+ where+ go acc [] = [acc []]+ go acc ('\\' : c : cs) | isSpace c = go (acc . (c :)) cs+ go acc (c : cs) | isSpace c = acc [] : words' cs+ | otherwise = go (acc . (c :)) cs++runScript :: String -- ^ filename+ -> InputT GHCi ()+runScript filename = do+ filename' <- expandPath filename+ either_script <- liftIO $ tryIO (openFile filename' ReadMode)+ case either_script of+ Left _err -> throwGhcException (CmdLineError $ "IO error: \""++filename++"\" "+ ++(ioeGetErrorString _err))+ Right script -> do+ st <- getGHCiState+ let prog = progname st+ line = line_number st+ setGHCiState st{progname=filename',line_number=0}+ scriptLoop script+ liftIO $ hClose script+ new_st <- getGHCiState+ setGHCiState new_st{progname=prog,line_number=line}+ where scriptLoop script = do+ res <- runOneCommand handler $ fileLoop script+ case res of+ Nothing -> return ()+ Just s -> if s+ then scriptLoop script+ else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: GhciMonad m => String -> m ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> reportError (GhciCommandSyntaxError "issafe <module>")++isSafeModule :: GHC.GhcMonad m => Module -> m ()+isSafeModule m = do+ mb_mod_info <- GHC.getModuleInfo m+ when (isNothing mb_mod_info)+ (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++ dflags <- getDynFlags+ hsc_env <- GHC.getSession+ let iface = GHC.modInfoIface $ fromJust mb_mod_info+ when (isNothing iface)+ (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++ (GHC.moduleNameString $ GHC.moduleName m))++ (msafe, pkgs) <- GHC.moduleTrustReqs m+ let trust = show $ getSafeMode $ GHC.mi_trust $ fromJust iface+ pkg = if packageTrusted hsc_env m then "trusted" else "untrusted"+ (good, bad) = tallyPkgs hsc_env pkgs++ -- print info to user...+ liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+ when (not $ S.null good)+ (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++ (intercalate ", " $ map (showPpr dflags) (S.toList good)))+ case msafe && S.null bad of+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"+ False -> do+ when (not $ null bad)+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+ ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))+ liftIO $ putStrLn $ mname ++ " is NOT trusted!"++ where+ mname = GHC.moduleNameString $ GHC.moduleName m++ packageTrusted hsc_env md+ | isHomeModule (hsc_home_unit hsc_env) md = True+ | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md)++ tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty)+ | otherwise = S.partition part deps+ where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg+ unit_state = hsc_units hsc_env+ dflags = hsc_dflags hsc_env++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()+browseCmd bang m =+ case words m of+ ['*':s] | looksLikeModuleName s -> do+ md <- wantInterpretedModule s+ browseModule bang md False+ [s] | looksLikeModuleName s -> do+ md <- lookupModule s+ browseModule bang md True+ [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+ browseModule bang md True+ _ -> throwGhcException (CmdLineError "syntax: :browse <module>")++guessCurrentModule :: GHC.GhcMonad m => String -> m Module+-- Guess which module the user wants to browse. Pick+-- modules that are interpreted first. The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd = do+ imports <- GHC.getContext+ case imports of+ [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module")+ IIModule m : _ -> pure m+ IIDecl d : _ -> do+ pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)+ GHC.findQualifiedModule pkgqual (unLoc (ideclName d))++-- without bang, show items in context of their parents and omit children+-- with bang, show class methods and data constructors separately, and+-- indicate import modules, to aid qualifying unqualified names+-- with sorted, sort items alphabetically+browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()+browseModule bang modl exports_only = do+ mb_mod_info <- GHC.getModuleInfo modl+ case mb_mod_info of+ Nothing -> throwGhcException (CmdLineError ("unknown module: " +++ GHC.moduleNameString (GHC.moduleName modl)))+ Just mod_info -> do+ names <-+ if exports_only+ then pure $ GHC.modInfoExports mod_info+ else do+ hsc_env <- GHC.getSession+ mmod_env <- liftIO $ mkTopLevEnv hsc_env modl+ case mmod_env of+ Left err -> throwGhcException (CmdLineError (GHC.moduleNameString (GHC.moduleName modl) ++ " " ++ err))+ Right mod_env -> pure $ map greName . globalRdrEnvElts $ mod_env+ let++ -- sort alphabetically name, but putting locally-defined+ -- identifiers first. We would like to improve this; see #1799.+ sorted_names = loc_sort local ++ occ_sort external+ where+ (local,external) = assert (all isExternalName names) $+ partition ((==modl) . nameModule) names+ occ_sort = sortBy (compare `on` nameOccName)+ -- try to sort by src location. If the first name in our list+ -- has a good source location, then they all should.+ loc_sort ns+ | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+ = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) ns+ | otherwise+ = occ_sort ns++ mb_things <- mapM GHC.lookupName sorted_names+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++ rdr_env <- GHC.getGRE++ let things | bang = catMaybes mb_things+ | otherwise = filtered_things+ pretty | bang = pprTyThing showToHeader+ | otherwise = pprTyThingInContext showToHeader++ labels [] = text "-- not currently imported"+ labels l = text $ intercalate "\n" $ map qualifier l++ qualifier :: Maybe [ModuleName] -> String+ qualifier = maybe "-- defined locally"+ (("-- imported via "++) . intercalate ", "+ . map GHC.moduleNameString)+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++ modNames :: [[Maybe [ModuleName]]]+ modNames = map (importInfo . GHC.getName) things++ -- annotate groups of imports with their import modules+ -- the default ordering is somewhat arbitrary, so we group+ -- by header and sort groups; the names themselves should+ -- really come in order of source appearance.. (#1799)+ annotate mts = concatMap (\(m,ts)->labels m:ts)+ $ sortBy cmpQualifiers $ grp mts+ where cmpQualifiers =+ compare `on` (map (fmap (map (unpackFS . moduleNameFS))) . fst)+ grp [] = []+ grp mts@((m,_):_) = (m,map snd g) : grp ng+ where (g,ng) = partition ((==m).fst) mts++ let prettyThings, prettyThings' :: [SDoc]+ prettyThings = map pretty things+ prettyThings' | bang = annotate $ zip modNames prettyThings+ | otherwise = prettyThings++ -- :browse reports qualifiers wrt current context+ rendered_things <- showSDocForUser' (vcat prettyThings')+ liftIO $ putStrLn rendered_things+ -- ToDo: modInfoInstances currently throws an exception for+ -- package modules. When it works, we can do this:+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context. For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: GhciMonad m => String -> m ()+moduleCmd str+ | all sensible strs = cmd+ | otherwise = reportError (GhciCommandSyntaxError "module [+/-] [*]M1 ... [*]Mn")+ where+ (cmd, strs) =+ case str of+ '+':stuff -> rest addModulesToContext stuff+ '-':stuff -> rest remModulesFromContext stuff+ stuff -> rest setContext stuff++ rest op stuff = (op as bs, stuffs)+ where (as,bs) = partitionWith starred stuffs+ stuffs = words stuff++ sensible ('*':m) = looksLikeModuleName m+ sensible m = looksLikeModuleName m++ starred ('*':m) = Left (GHC.mkModuleName m)+ starred m = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+-- (a) :module +<stuff>: addModulesToContext+-- (b) :module -<stuff>: remModulesFromContext+-- (c) :module <stuff>: setContext+-- (d) import <module>...: addImportToContext++addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+ addModulesToContext_ starred unstarred++addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+addModulesToContext_ starred unstarred = do+ starredModules <- traverse lookupModuleName starred+ mapM_ addII (map mkIIModule starredModules ++ map mkIIDecl unstarred)+ setGHCContextFromGHCiState++remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+remModulesFromContext starred unstarred = do+ -- we do *not* call restoreContextOnFailure here. If the user+ -- is trying to fix up a context that contains errors by removing+ -- modules, we don't want GHC to silently put them back in again.+ mapM_ rm (starred ++ unstarred)+ setGHCContextFromGHCiState+ where+ rm :: GhciMonad m => ModuleName -> m ()+ rm str = do+ m <- moduleName <$> lookupModuleName str+ let filt = filter ((/=) m . iiModuleName)+ modifyGHCiState $ \st ->+ st { remembered_ctx = filt (remembered_ctx st)+ , transient_ctx = filt (transient_ctx st) }++setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+setContext starred unstarred = restoreContextOnFailure $ do+ modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+ -- delete the transient context+ addModulesToContext_ starred unstarred++addImportToContext :: GhciMonad m => ImportDecl GhcPs -> m ()+addImportToContext idecl = restoreContextOnFailure $ do+ addII (IIDecl idecl) -- #5836+ setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: GhciMonad m => InteractiveImport -> m ()+addII iidecl = do+ checkAdd iidecl+ modifyGHCiState $ \st ->+ st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+ , transient_ctx = filter (not . (iidecl `iiSubsumes`))+ (transient_ctx st)+ }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'. e.g.+--+-- import System.IO (foo)+--+-- will fail because System.IO does not export foo. In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GhciMonad m => m a -> m a+restoreContextOnFailure do_this = do+ st <- getGHCiState+ let rc = remembered_ctx st; tc = transient_ctx st+ do_this `MC.onException` (modifyGHCiState $ \st' ->+ st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()+checkAdd ii = do+ dflags <- getDynFlags+ let safe = safeLanguageOn dflags+ case ii of+ IIModule mod+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> checkInterpretedModule mod >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual <- GHC.renameRawPkgQualM modname (ideclPkgQual d)+ m <- lookupQualifiedModuleName pkgqual modname+ when safe $ do+ t <- GHC.isModuleTrusted m+ unless t $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state. The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist. This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list. Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GhciMonad m => m ()+setGHCContextFromGHCiState = do+ st <- getGHCiState+ -- re-use checkAdd to check whether the module is valid. If the+ -- module does not exist, we do *not* want to print an error+ -- here, we just want to silently keep the module in the context+ -- until such time as the module reappears again. So we ignore+ -- the actual exception thrown by checkAdd, using tryBool to+ -- turn it into a Bool.+ iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)++ prel_iidecls <- getImplicitPreludeImports iidecls+ valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls++ extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))++ GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls+++getImplicitPreludeImports :: GhciMonad m+ => [InteractiveImport] -> m [InteractiveImport]+getImplicitPreludeImports iidecls = do+ -- allow :seti to override -XNoImplicitPrelude+ st <- getGHCiState++ -- We add the prelude imports if there are no *-imports, and we also+ -- allow each prelude import to be subsumed by another explicit import+ -- of the same module. This means that you can override the prelude import+ -- with "import Prelude hiding (map)", for example.+ let prel_iidecls =+ if not (any isIIModule iidecls)+ then [ IIDecl imp+ | imp <- prelude_imports st+ , not (any (sameImpModule imp) iidecls) ]+ else []++ -- See Note [GHCi and local Preludes]+ keepPackageImports prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: Module -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [Module]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = moduleName m+iiModuleName (IIDecl d) = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Clash.Prelude"++sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool+sameImpModule _ (IIModule _) = False -- we only care about imports here+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)++addNotSubsumed :: InteractiveImport+ -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+ | any (`iiSubsumes` i) is = is+ | otherwise = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+ -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one. Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude+ = unLoc (ideclName d1) == unLoc (ideclName d2)+ && ideclAs d1 == ideclAs d2+ && convImportLevel (ideclLevelSpec d1) == convImportLevel (ideclLevelSpec d2)+ && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))+ && (ideclImportList d1 `hidingSubsumes` ideclImportList d2)+ where+ _ `hidingSubsumes` Just (Exactly,L _ []) = True+ Just (Exactly, L _ xs) `hidingSubsumes` Just (Exactly,L _ ys)+ = all (`elem` xs) ys+ h1 `hidingSubsumes` h2 = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter. Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected. ToDo:+-- figure out which ones & disallow them.++setCmd :: GhciMonad m => String -> m ()+setCmd "" = showOptions False+setCmd "-a" = showOptions True+setCmd str+ = case getCmd str of+ Right ("args", rest) -> toArgsNoLocWithErrorHandler rest setArgs+ Right ("prog", rest) -> toArgsNoLocWithErrorHandler rest $ \case+ [prog] -> setProg prog+ _ -> reportError $ GhciCommandSyntaxError "set prog <progname>"+ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ (GhciCommandSyntaxError "set promp <string>")+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ (GhciCommandSyntaxError "set prompt-cont <string>")+ Right ("prompt-cont-function", rest) ->+ setPromptFunc setPromptCont $ dropWhile isSpace rest+ Right ("editor", rest) -> setEditor $ dropWhile isSpace rest+ Right ("stop", rest) -> setStop $ dropWhile isSpace rest+ Right ("local-config", rest) ->+ setLocalConfigBehaviour $ dropWhile isSpace rest+ _ -> toArgsNoLocWithErrorHandler str $ \wds -> () <$ keepGoing' setOptions wds++setiCmd :: GhciMonad m => String -> m ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str = toArgsNoLocWithErrorHandler str (newDynFlags True)++showOptions :: GhciMonad m => Bool -> m ()+showOptions show_all+ = do st <- getGHCiState+ dflags <- getDynFlags+ let opts = options st+ liftIO $ putStrLn (showSDoc dflags (+ text "options currently set: " <>+ if null opts+ then text "none."+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+ ))+ mapNonInteractiveHomeUnitsM (liftIO . showDynFlags show_all)++mapNonInteractiveHomeUnitsM :: GHC.GhcMonad m => (DynFlags -> m ()) -> m ()+mapNonInteractiveHomeUnitsM printer = do+ hug <- hsc_HUG <$> GHC.getSession+ singleOrMultipleHomeUnits+ $ map (\(uid, homeUnit) -> (uid, homeUnitEnv_dflags homeUnit))+ $ filter (\(uid, _) -> uid /= interactiveSessionUnitId+ && uid /= interactiveGhciUnitId)+ $ HUG.unitEnv_assocs hug+ where+ singleOrMultipleHomeUnits [] =+ liftIO $ putStrLn "GHCi: internal error - no home unit configured"+ singleOrMultipleHomeUnits [(_, dflags)] = printer dflags+ singleOrMultipleHomeUnits xs = mapM_ (\(uid, dflags) -> do+ liftIO $ putStrLn (showSDoc dflags (text "Unit ID:" <+> ppr uid))+ printer dflags) xs++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+ showLanguages' show_all dflags+ putStrLn $ showSDoc dflags $+ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))+ putStrLn $ showSDoc dflags $+ text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))+ putStrLn $ showSDoc dflags $+ text "warning settings:" $$+ nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))+ where+ setting :: String -> String -> (flag -> DynFlags -> Bool) -> FlagSpec flag -> SDoc+ setting prefix noPrefix test flag+ | quiet = empty+ | is_on = text prefix <> text name+ | otherwise = text noPrefix <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags = defaultDynFlags (settings dflags)++ (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs)+ DynFlags.fFlags+ flgs = [ Opt_PrintExplicitForalls+ , Opt_PrintExplicitKinds+ , Opt_PrintUnicodeSyntax+ , Opt_PrintBindResult+ , Opt_BreakOnException+ , Opt_BreakOnError+ , Opt_PrintEvldWithShow+ ]++setArgs, setOptions :: GhciMonad m => [String] -> m ()+setProg, setEditor, setStop :: GhciMonad m => String -> m ()+setLocalConfigBehaviour :: GhciMonad m => String -> m ()++setArgs args = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper (progname st) args+ setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }++setProg prog = do+ st <- getGHCiState+ wrapper <- mkEvalWrapper prog (GhciMonad.args st)+ setGHCiState st { progname = prog, evalWrapper = wrapper }++setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setLocalConfigBehaviour s+ | s == "source" =+ modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })+ | s == "ignore" =+ modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })+ | otherwise = reportError (GhciCommandSyntaxError "set local-config { source | ignore }")++setStop str@(c:_) | isDigit c+ = do let (nm_str,rest) = break (not.isDigit) str+ nm = read nm_str+ st <- getGHCiState+ let old_breaks = breaks st+ case IntMap.lookup nm old_breaks of+ Nothing -> printForUser (text "Breakpoint" <+> ppr nm <+>+ text "does not exist")+ Just loc -> do+ let new_breaks = IntMap.insert nm+ loc { onBreakCmd = dropWhile isSpace rest }+ old_breaks+ setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: GhciMonad m => PromptFunction -> m ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: GhciMonad m => PromptFunction -> m ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()+setPromptFunc fSetPrompt s = do+ -- We explicitly annotate the type of the expression to ensure+ -- that unsafeCoerce# is passed the exact type necessary rather+ -- than a more general one+ let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"+ (HValue funValue) <- GHC.compileExpr exprStr+ fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)+ where+ convertToPromptFunction :: ([String] -> Int -> IO String)+ -> PromptFunction+ convertToPromptFunction func = (\mods line -> liftIO $+ liftM text (func mods line))++setPromptString :: GhciMonad m+ => (PromptFunction -> m ()) -> String -> GhciCommandMessage -> m ()+setPromptString fSetPrompt value err = do+ if null value+ then reportError err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> reportError GhciInvalidPromptString+ _ ->+ setParsedPromptString fSetPrompt value++setParsedPromptString :: MonadIO m+ => (PromptFunction -> m ()) -> String -> m ()+setParsedPromptString fSetPrompt s = do+ case (checkPromptStringForErrors s) of+ Just err ->+ liftIO $ hPutStrLn stderr err+ Nothing ->+ fSetPrompt $ generatePromptFunctionFromString s++setOptions wds =+ do -- first, deal with the GHCi opts (+s, +t, etc.)+ let (plus_opts, minus_opts) = partitionWith isPlus wds+ mapM_ setOpt plus_opts+ -- then, dynamic flags+ when (not (null minus_opts)) $ newDynFlags False minus_opts++-- Note [No unused package warnings for the interactive session]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The interactive session (also called "interactive-prompt" occassionally) should not+-- report unused packages, as it will essentially always report packages+-- as unused.+-- The "interactive-prompt" doesn't contain any 'Module's, so most packages+-- are unused.+-- As this would flood the user with warnings they can't do anything about,+-- we decide to unconditionally turn off the warning 'Opt_WarnUnusedPackages'.+--+-- Unused packages in GHCi are still reported via the 'interactive-session' unit.+-- See Note [Multiple Home Units aware GHCi] for an explanation about the+-- "interactive-prompt" and 'interactive-session' unit.++-- | 'newDynFlags' adds the given user options to the session.+--+-- If 'True' is passed, we add the options only to the interactive 'DynFlags'.+-- Otherwise, the options are added to each 'HomeUnitEnv' in the current session.+--+-- This function will check whether we need to re-initialise the 'UnitState',+-- for example when the user writes ':set -package containers'.+--+-- Any warnings during parsing, or validation of the new 'DynFlags' will be+-- directly reported to the user.+newDynFlags :: GhciMonad m => Bool -> [String] -> m ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ case interactive_only of+ True -> addToInteractiveDynFlags lopts+ False -> addToProgramDynFlags lopts++ idflags <- hsc_dflags <$> GHC.getSession+ installInteractivePrint (interactivePrint idflags) False++-- | Add the given options to the interactive 'DynFlags'.+-- This function will normalise and validate the 'DynFlags' and report warnings+-- directly to the user.+--+-- Updates both the 'hsc_dflags' of 'HscEnv', and the 'ic_dflags' of the 'InteractiveContext'.+--+-- 'addToInteractiveDynFlags' will *not* read package environment files, therefore we+-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This+-- function is called very often and results in repeatedly loading+-- environment files (see #19650)+addToInteractiveDynFlags :: GhciMonad m => [Located String] -> m ()+addToInteractiveDynFlags lopts = do+ logger <- getLogger+ env <- GHC.getSession+ let idflags0 = hsc_dflags env+ (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts++ liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)+ when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)++ when (packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"++ idflags_norm <- GHC.normaliseInteractiveDynFlags logger idflags1+ -- Strictly speaking, 'setProgramHUG' performs more work than necessary,+ -- as we know the majority of flags haven't changed.+ _ <- GHC.setProgramHUG (hsc_HUG $ hscSetFlags idflags_norm env)+ -- Initialise the Interactive DynFlags.+ -- Sets the 'ic_dflags' and initialises the 'ic_plugins'.+ -- See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']+ idflags <- hsc_dflags <$> GHC.getSession+ modifySessionM (GHC.initialiseInteractiveDynFlags idflags)++-- | Add the given options to all 'DynFlags' in the 'HomeUnitGraph'.+-- This function will validate the 'DynFlags' and report warnings directly to the user.+--+-- We additionally normalise the 'DynFlags' for the 'interactiveGhciUnitId' for use+-- in the 'InteractiveContext'.+--+-- 'addToProgramDynFlags' will *not* read package environment files, therefore we+-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This+-- function is called very often and results in repeatedly loading+-- environment files (see #19650)+addToProgramDynFlags :: GhciMonad m => [Located String] -> m ()+addToProgramDynFlags lopts = do+ logger <- getLogger+ initial_hug <- hsc_HUG <$> GHC.getSession+ -- Update the 'DynFlags' of each 'HomeUnitEnv'.+ -- Parse the new 'DynFlags', and report potential issues once.+ -- Arguably, we may want to report issues for each non-builtin 'HomeUnitEnv'+ -- individually.+ updates <- HUG.unitEnv_traverseWithKey (\uid homeUnitEnv -> do+ let oldFlags = HUG.homeUnitEnv_dflags homeUnitEnv+ (newFlags, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger oldFlags lopts+ -- We only want to report inconsistencies and warnings once.+ -- Thus, we do it only once for the 'interactiveGhciUnitId'+ when (uid == interactiveGhciUnitId) $ do+ liftIO $ printOrThrowDiagnostics logger (initPrintConfig newFlags) (initDiagOpts newFlags) (GhcDriverMessage <$> warns)+ when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)++ -- Special Logic!+ -- Currently, the interactive 'DynFlags' have additional restrictions,+ -- for example modifying package flags is not supported!+ -- The interactive 'DynFlags' get normalised to uphold this restriction.+ -- As a special precaution, we also don't want to report unusued packages warnings+ -- for the interactive session.+ -- See Note [No unused package warnings for the interactive session]+ --+ -- See Note [Multiple Home Units aware GHCi] for details about how+ -- the interactive session is structured.+ newFlags' <-+ if uid == interactiveGhciUnitId+ then do+ -- See Note [No unused package warnings for the interactive session]+ let icdflags1 = wopt_unset newFlags Opt_WarnUnusedPackages+ GHC.normaliseInteractiveDynFlags logger icdflags1+ else+ pure newFlags+ pure (homeUnitEnv { homeUnitEnv_dflags = newFlags' })+ )+ initial_hug+ -- Update the HUG!+ -- This might force us to reload the 'UnitState' of each 'HomeUnitEnv'+ -- if package flags were changed.+ must_reload <- GHC.setProgramHUG updates++ -- Initialise the Interactive DynFlags.+ -- Sets the 'ic_dflags' and initialises the 'ic_plugins'.+ -- See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']+ icdflags <- hsc_dflags <$> GHC.getSession+ modifySessionM (GHC.initialiseInteractiveDynFlags icdflags)++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ when must_reload $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."++ -- Clear caches and eventually defined breakpoints. (#1620)+ clearCaches++ reloadPackages hsc_env++ reloadLinkerOptions hsc_env initial_hug++reloadPackages :: GhciMonad m => HscEnv -> m ()+reloadPackages hsc_env = do+ let+ units =+ concatMap (preloadUnits . HUG.homeUnitEnv_units)+ (Foldable.toList $ hsc_HUG hsc_env)+ liftIO $ Loader.loadPackages (hscInterp hsc_env) hsc_env units+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False Nothing++-- | Reload the linker options.+--+-- Synopsis: @'reloadLinkerOptions' hsc_env old_hug@+--+-- After the HUG is modified, the linker may need to be reloaded.+-- The linker is reloaded via 'loadCmdLineLibs', if the library inputs+-- have changed.+-- To determine whether the library inputs have changed, we need the+-- old HUG, which is passed as the argument 'old_hug'.+--+-- This function will crash, if the 'old_hug' doesn't have exactly+-- the same keys has the given 'hsc_env'. I.e.+--+-- @+-- HUG.unitEnv_keys old_hug == HUG.unitEnv_keys (hsc_HUG hsc_env)+-- @+reloadLinkerOptions :: MonadIO m => HscEnv -> HomeUnitGraph -> m ()+reloadLinkerOptions hsc_env old_hug = do+ let+ new_hug = hsc_HUG hsc_env+ let+ (needs_updates, updated_hug) = HUG.unitEnv_traverseWithKey (\key unitEnv ->+ let+ old_flags = homeUnitEnv_dflags (HUG.unitEnv_lookup key old_hug)+ new_flags = homeUnitEnv_dflags unitEnv+ ld0length = length $ ldInputs old_flags+ fmrk0length = length $ cmdlineFrameworks old_flags++ newLdInputs = drop ld0length (ldInputs new_flags)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks new_flags)++ dflags' = new_flags { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks+ }+ in+ (S.Any (not (null newLdInputs && null newCLFrameworks)),+ unitEnv { homeUnitEnv_dflags = dflags' })+ ) new_hug++ hsc_env' =+ hscSetActiveUnitId (hscActiveUnitId hsc_env)+ $ hscUpdateHUG (const updated_hug)+ $ hsc_env++ when (S.getAny needs_updates) $+ liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'++unknownFlagsErr :: GhciMonad m => [String] -> m ()+unknownFlagsErr fs = mapM_ (\f -> reportError (GhciUnknownFlag f (suggestions f))) fs+ where+ suggestions f = flagSuggestions (nubSort $ flagsForCompletion True) f++unsetOptions :: GhciMonad m => String -> m ()+unsetOptions str+ = -- first, deal with the GHCi opts (+s, +t, etc.)+ let opts = words str+ (minus_opts, rest1) = partition isMinus opts+ (plus_opts, rest2) = partitionWith isPlus rest1+ (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++ defaulters =+ [ ("args" , setArgs default_args)+ , ("prog" , setProg default_progname)+ , ("prompt" , setPrompt default_prompt)+ , ("prompt-cont", setPromptCont default_prompt_cont)+ , ("editor" , liftIO findEditor >>= setEditor)+ , ("stop" , setStop default_stop)+ ]++ no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+ no_flag ('-':'X':rest) = return ("-XNo" ++ rest)+ no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++ in case rest3 of+ opt:_ -> liftIO (putStrLn ("unknown option: '" ++ opt ++ "'"))+ [] -> do+ mapM_ (fromJust.flip lookup defaulters) other_opts++ mapM_ unsetOpt plus_opts++ no_flags <- mapM no_flag minus_opts+ when (not (null no_flags)) $ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other = Right other++setOpt, unsetOpt :: GhciMonad m => String -> m ()++setOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> setOption o++unsetOpt str+ = case strToGHCiOpt str of+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+ Just o -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo+strToGHCiOpt _ = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline = "m"+optToStr ShowTiming = "s"+optToStr ShowType = "t"+optToStr RevertCAFs = "r"+optToStr CollectInfo = "c"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: forall m. GhciMonad m => String -> m ()+showCmd "" = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+ st <- getGHCiState+ hsc_env <- GHC.getSession++ let lookupCmd :: String -> Maybe (m ())+ lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++ -- (show in help?, command name, action)+ action :: String -> m () -> (Bool, String, m ())+ action name m = (True, name, m)++ hidden :: String -> m () -> (Bool, String, m ())+ hidden name m = (False, name, m)++ cmds =+ [ action "args" $ liftIO $ putStrLn (show (GhciMonad.args st))+ , action "prog" $ liftIO $ putStrLn (show (progname st))+ , action "editor" $ liftIO $ putStrLn (show (editor st))+ , action "stop" $ liftIO $ putStrLn (show (stop st))+ , action "imports" $ showImports+ , action "modules" $ showModules+ , action "bindings" $ showBindings+ , action "linker" $ do+ msg <- liftIO $ Loader.showLoaderState (hscInterp hsc_env)+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags msg+ , action "breaks" $ showBkptTable+ , action "context" $ showContext+ , action "packages" $ showUnits+ , action "paths" $ showPaths+ , action "language" $ showLanguages+ , hidden "languages" $ showLanguages -- backwards compat+ , hidden "lang" $ showLanguages -- useful abbreviation+ , action "targets" $ showTargets+ ]++ case words str of+ [w] | Just action <- lookupCmd w -> action++ _ -> do+ let helpCmds = [ text name | (True, name, _) <- cmds ]+ dflags <- getDynFlags+ throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: GhciMonad m => String -> m ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> reportError (GhciCommandSyntaxError "showi language")++showImports :: GhciMonad m => m ()+showImports = do+ st <- getGHCiState+ dflags <- getDynFlags+ let rem_ctx = reverse (remembered_ctx st)+ trans_ctx = transient_ctx st++ show_one (IIModule star_m)+ = ":module +*" ++ moduleNameString (moduleName star_m)+ show_one (IIDecl imp) = showPpr dflags imp++ prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)++ let show_prel p = show_one p ++ " -- implicit"+ show_extra p = show_one (IIDecl p) ++ " -- fixed"++ trans_comment s = s ++ " -- added automatically" :: String+ --+ liftIO $ mapM_ putStrLn (map show_one rem_ctx +++ map (trans_comment . show_one) trans_ctx +++ map show_prel prel_iidecls +++ map show_extra (extra_imports st))++showModules :: GHC.GhcMonad m => m ()+showModules = do+ loaded_mods <- getLoadedModules+ -- we want *loaded* modules only, see #1734+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+ mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModuleNodeInfo]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM isLoadedModuleNode (mapMaybe GHC.mgNodeIsModule (GHC.mgModSummaries' graph))++showBindings :: GHC.GhcMonad m => m ()+showBindings = do+ bindings <- GHC.getBindings+ (insts, finsts) <- GHC.getInsts+ let idocs = map GHC.pprInstanceHdr insts+ fidocs = map GHC.pprFamInst finsts+ binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525+ -- See Note [Filter bindings]+ docs <- mapM makeDoc (reverse binds)+ -- reverse so the new ones come last+ mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+ where+ makeDoc (AnId i) = pprTypeAndContents i+ makeDoc tt = do+ mb_stuff <- GHC.getInfo False (getName tt)+ return $ maybe (text "") pprTT mb_stuff++ pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+ pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)+ = pprTyThing showToHeader thing+ $$ showFixity thing fixity+++printTyThing :: GHC.GhcMonad m => TyThing -> m ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++isLoadedModuleNode :: GHC.GhcMonad m => GHC.ModuleNodeInfo -> m Bool+isLoadedModuleNode ms =+ let m = GHC.moduleNodeInfoModule ms+ in GHC.isLoadedModule (moduleUnitId m) (moduleName m)++{-+Note [Filter bindings]+~~~~~~~~~~~~~~~~~~~~~~+If we don't filter the bindings returned by the function GHC.getBindings,+then the :show bindings command will also show unwanted bound names,+internally generated by GHC, eg:+ $tcFoo :: GHC.Types.TyCon = _+ $trModule :: GHC.Unit.Module = _ .++The filter was introduced as a fix for #12525 [1]. Comment:1 [2] to this+ticket contains an analysis of the situation and suggests the solution+implemented above.++The same filter was also implemented to fix #11051 [3]. See the+Note [What to show to users] in GHC.Runtime.Eval++[1] https://gitlab.haskell.org/ghc/ghc/issues/12525+[2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489+[3] https://gitlab.haskell.org/ghc/ghc/issues/11051+-}+++showBkptTable :: GhciMonad m => m ()+showBkptTable = do+ st <- getGHCiState+ printForUser $ prettyLocations (breaks st)++showContext :: GHC.GhcMonad m => m ()+showContext = do+ resumes <- GHC.getResumeContext+ docs <- mapM pp_resume (reverse resumes)+ printForUser $ vcat docs+ where+ pp_resume res = do+ stopped <- pprStopped res+ return $+ text "--> " <> text (GHC.resumeStmt res)+ $$ nest 2 stopped++pprStopped :: GHC.GhcMonad m => GHC.Resume -> m SDoc+pprStopped res = do+ let mibi = GHC.resumeBreakpointId res+ mb_mod_name <- case mibi of+ Nothing -> pure Nothing+ Just ibi -> do+ hug <- hsc_HUG <$> GHC.getSession+ brks <- liftIO $ readIModBreaks hug ibi+ return $ Just $ moduleName $+ getBreakSourceMod ibi brks+ return $+ text "Stopped in"+ <+> ((case mb_mod_name of+ Nothing -> empty+ Just mod_name -> ftext (moduleNameFS mod_name) <> char '.')+ <> text (GHC.resumeDecl res))+ <> char ',' <+> ppr (GHC.resumeSpan res)++showUnits :: GHC.GhcMonad m => m ()+showUnits = mapNonInteractiveHomeUnitsM $ \dflags -> do+ let pkg_flags = packageFlags dflags+ liftIO $ putStrLn $ showSDoc dflags $+ text ("active package flags:"++if null pkg_flags then " none" else "") $$+ nest 2 (vcat (map pprFlag pkg_flags))++showPaths :: GHC.GhcMonad m => m ()+showPaths = mapNonInteractiveHomeUnitsM $ \dflags -> do+ liftIO $ do+ cwd <- getCurrentDirectory+ putStrLn $ showSDoc dflags $+ text "current working directory: " $$+ nest 2 (text cwd)+ let ipaths = importPaths dflags+ putStrLn $ showSDoc dflags $+ text ("module import search paths:"++if null ipaths then " none" else "") $$+ nest 2 (vcat (map text ipaths))++showLanguages :: GHC.GhcMonad m => m ()+showLanguages = mapNonInteractiveHomeUnitsM $ liftIO . showLanguages' False++showiLanguages :: GHC.GhcMonad m => m ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+ putStrLn $ showSDoc dflags $ vcat+ [ text "base language is: " <>+ case lang of+ Haskell98 -> text "Haskell98"+ Haskell2010 -> text "Haskell2010"+ GHC2021 -> text "GHC2021"+ GHC2024 -> text "GHC2024"+ , (if show_all then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+ ]+ where+ setting test flag+ | quiet = empty+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags = defaultDynFlags (settings dflags) `lang_set` Just lang++ lang = fromMaybe defaultLanguage (language dflags)+++showTargets :: GHC.GhcMonad m => m ()+showTargets = mapM_ showTarget =<< GHC.getTargets+ where+ showTarget :: GHC.GhcMonad m => Target -> m ()+ showTarget Target { targetId = TargetFile f _ } = liftIO (putStrLn f)+ showTarget Target { targetId = TargetModule m } =+ liftIO (putStrLn $ moduleNameString m)++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+ Just ("repl", resultRange, left) -> do+ (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+ let compls' = takeRange resultRange compls+ liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+ forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+ liftIO $ print r+ _ -> reportError (GhciCommandSyntaxError "complete repl [<range>] <quoted-string-to-complete>")+ where+ parseLine [] = Nothing+ parseLine argLine = case breakSpace argLine of+ (_, []) -> Nothing+ (dom, rest1@('"' : _)) -> (dom,,) <$> parseRange "" <*> (readMaybe rest1 :: Maybe String)+ (dom, rest1) -> (dom,,) <$> parseRange rng <*> readMaybe rest2+ where+ (rng, rest2) = breakSpace rest1++ breakSpace = fmap (dropWhile isSpace) . break isSpace++ takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++ -- syntax: [n-][m] with semantics "drop (n-1) . take m"+ parseRange :: String -> Maybe (Maybe Int,Maybe Int)+ parseRange s = case span isDigit s of+ (_, "") ->+ -- upper limit only+ Just (Nothing, bndRead s)+ (s1, '-' : s2)+ | all isDigit s2 ->+ Just (bndRead s1, bndRead s2)+ _ ->+ Nothing+ where+ bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+ completeSetModule, completeSeti, completeShowiOptions,+ completeSetOptions, completeShowOptions,+ completeHomeModuleOrFile, completeExpression, completeBreakpoint+ :: GhciMonad m => CompletionFunc m++-- | Provide completions for last word in a given string.+--+-- Takes a tuple of two strings. First string is a reversed line to be+-- completed. Second string is likely unused, 'completeCmd' always passes an+-- empty string as second item in tuple.+ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+ -- If given string starts with `:` colon, and there is only one following+ -- word then provide REPL command completions. If there is more than one+ -- word complete either filename or builtin ghci commands or macros.+ ':':cmd | null rest -> completeGhciCommand line+ | otherwise -> do+ completion <- lookupCompletion cmd+ completion line+ -- If given string starts with `import` keyword provide module name+ -- completions+ "import" -> completeModule line+ -- otherwise provide identifier completions+ _ -> completeExpression line+ where+ (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+ lookupCompletion ('!':_) = return completeFilename+ lookupCompletion c = do+ maybe_cmd <- lookupCommand' c+ case maybe_cmd of+ Just cmd -> return (cmdCompletionFunc cmd)+ Nothing -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+ macros <- ghci_macros <$> getGHCiState+ cmds <- ghci_commands `fmap` getGHCiState+ let macro_names = map (':':) . map cmdName $ macros+ let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds+ let{ candidates = case w of+ ':' : ':' : _ -> map (':':) command_names+ _ -> nub $ macro_names ++ command_names }+ return $ filter (w `isPrefixOptOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+ cmds <- ghci_macros <$> getGHCiState+ return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier line@(left, _) =+ -- Note: `left` is a reversed input+ case left of+ ('.':_) -> wrapCompleter (specials ++ spaces) complete line+ -- operator or qualification+ (x:_) | isSymbolChar x -> wrapCompleter' (\c -> c `elem` (specials ++ spaces) || not (isSymbolChar c))+ complete line -- operator+ _ -> wrapIdentCompleter complete line+ where+ complete w = do+ rdrs <- GHC.getRdrNamesInScope+ dflags <- GHC.getSessionDynFlags+ return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++-- TAB-completion for the :break command.+-- Build and return a list of breakpoint identifiers with a given prefix.+-- See Note [Tab-completion for :break]+completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000+ -- bid ~ breakpoint identifier = a name of a function that is+ -- eligible to set a breakpoint.+ let (mod_str, _, _) = splitIdent w+ bids_mod_breaks <- bidsFromModBreaks mod_str+ bids_inscopes <- bidsFromInscopes+ pure $ nub $ filter (isPrefixOf w) $ bids_mod_breaks ++ bids_inscopes+ where+ -- Extract all bids from ModBreaks for a given module name prefix+ bidsFromModBreaks :: GhciMonad m => String -> m [String]+ bidsFromModBreaks mod_pref = do+ imods <- interpretedHomeMods+ let pmods = filter ((isPrefixOf mod_pref) . showModule) imods+ nonquals <- case null mod_pref of+ -- If the prefix is empty, then for functions declared in a module+ -- in scope, don't qualify the function name.+ -- (eg: `main` instead of `Main.main`)+ True -> do+ imports <- GHC.getContext+ pure [ m | IIModule m <- imports]+ False -> return []+ bidss <- mapM (bidsByModule nonquals) pmods+ pure $ concat bidss++ -- Return a list of interpreted home modules+ interpretedHomeMods :: GhciMonad m => m [Module]+ interpretedHomeMods = do+ graph <- GHC.getModuleGraph+ let hmods = ms_mod <$> GHC.mgModSummaries graph+ filterM GHC.moduleIsInterpreted hmods++ -- Return all possible bids for a given Module+ bidsByModule :: GhciMonad m => [Module] -> Module -> m [String]+ bidsByModule nonquals mod = do+ mb_decls <- fmap GHC.modBreaks_decls <$> getModBreak mod+ let bids = case mb_decls of+ Just decls -> nub $ declPath <$> elems decls+ Nothing -> []+ pure $ case mod `elem` nonquals of+ True -> bids+ False -> (combineModIdent (showModule mod)) <$> bids++ -- Extract all bids from all top-level identifiers in scope.+ bidsFromInscopes :: GhciMonad m => m [String]+ bidsFromInscopes = do+ dflags <- getDynFlags+ rdrs <- GHC.getRdrNamesInScope+ inscopess <- mapM createInscope $ (showSDoc dflags . ppr) <$> rdrs+ imods <- interpretedHomeMods+ let topLevels = filter ((`elem` imods) . snd) $ concat inscopess+ bidss <- mapM (addNestedDecls) topLevels+ pure $ concat bidss++ -- Return a list of (bid,module) for a single top-level in-scope identifier+ createInscope :: GhciMonad m => String -> m [(String, Module)]+ createInscope str_rdr = do+ names <- GHC.parseName str_rdr+ pure $ map (str_rdr, ) $ NE.toList $ GHC.nameModule <$> names++ -- For every top-level identifier in scope, add the bids of the nested+ -- declarations. See Note [Field modBreaks_decls] in GHC.ByteCode.Types+ addNestedDecls :: GhciMonad m => (String, Module) -> m [String]+ addNestedDecls (ident, mod) = do+ mb_decls <- fmap GHC.modBreaks_decls <$> getModBreak mod+ case mb_decls of+ Nothing -> pure []+ Just decls -> do+ let (mod_str, topLvl, _) = splitIdent ident+ ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ]+ bids = nub $ declPath <$> ident_decls+ pure $ map (combineModIdent mod_str) bids++completeModule = wrapIdentCompleterMod $ \w -> do+ hsc_env <- GHC.getSession+ let pkg_mods = allVisibleModules (hsc_units hsc_env)+ loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules+ return $ filter (w `isPrefixOf`)+ $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+ hsc_env <- GHC.getSession+ modules <- case m of+ Just '-' -> do+ imports <- GHC.getContext+ return $ map iiModuleName imports+ _ -> do+ let pkg_mods = allVisibleModules (hsc_units hsc_env)+ loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules++listHomeModules :: GHC.GhcMonad m => String -> m [String]+listHomeModules w = do+ g <- GHC.getModuleGraph+ let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)+ dflags <- getDynFlags+ return $ sort $ filter (w `isPrefixOf`)+ $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":+ "prompt-cont-function":"editor":"stop":flagList+ flagList = map NE.head $ NE.group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) flagList)+ where flagList = map NE.head $ NE.group $ sort allNonDeprecatedFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) opts)+ where opts = ["args", "prog", "editor", "stop",+ "modules", "bindings", "linker", "breaks",+ "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+ return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+ $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+ listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+ cs1 <- f1 line+ cs2 <- f2 line+ return (cs1 ++ cs2)++wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m+wrapCompleter breakChars = wrapCompleter' (`elem` breakChars)++wrapCompleter' :: Monad m => (Char -> Bool) -> (String -> m [String]) -> CompletionFunc m+wrapCompleter' breakPred fun = completeWord' Nothing breakPred+ $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m+wrapIdentCompleter = wrapCompleter' word_break_chars_pred++wrapIdentCompleterMod :: Monad m => (String -> m [String]) -> CompletionFunc m+wrapIdentCompleterMod = wrapCompleter' go+ where+ go '.' = False -- Treated specially since it is a separator for module qualifiers+ go c = word_break_chars_pred c++wrapIdentCompleterWithModifier+ :: Monad m+ => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+ $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)+ where+ getModifier = find (`elem` modifChars)++-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: UnitState -> [ModuleName]+allVisibleModules unit_state = listVisibleModuleNames unit_state++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+ completeIdentifier+++{-+Note [Tab-completion for :break]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In tab-completion for the `:break` command, only those+identifiers should be shown, that are accepted in the+`:break` command. Hence these identifiers must be++- defined in an interpreted module+- listed in a `ModBreaks` value as a possible breakpoint.++The identifiers may be qualified or unqualified.++To get all possible top-level breakpoints for tab-completion+with the correct qualification do:++1. Build a list called `bids_mod_breaks` of identifier names eligible+for setting breakpoints: For every interpreted module with the+correct module prefix read all identifier names from the `decls` field+of the `ModBreaks` array.++2. Build a list called `bids_inscopess` of identifiers in scope:+Take all RdrNames in scope, and filter by interpreted modules.+Fore each of these top-level identifiers add from the `ModBreaks`+arrays the available identifiers of the nested functions.++3.) Combine both lists, filter by the given prefix, and remove duplicates.+-}++-- -----------------------------------------------------------------------------+-- commands for debugger++sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()+sprintCmd = pprintClosureCommand False False+printCmd = pprintClosureCommand True False+forceCmd = pprintClosureCommand False True++stepCmd :: GhciMonad m => String -> m ()+stepCmd arg = withSandboxOnly ":step" $ step arg+ where+ step [] = doContinue GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++stepOutCmd :: GhciMonad m => String -> m ()+stepOutCmd _ = withSandboxOnly ":stepout" $ do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> doContinue (GHC.StepOut Nothing)+ Just loc -> do+ md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule+ current_toplevel_decl <- flip enclosingTickSpan loc <$> getTickArray md+ doContinue (GHC.StepOut (Just (RealSrcSpan current_toplevel_decl Strict.Nothing)))++stepLocalCmd :: GhciMonad m => String -> m ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just (UnhelpfulSpan _) -> liftIO $ putStrLn ( -- #14690+ ":steplocal is not possible." +++ "\nCannot determine current top-level binding after " +++ "a break on error / exception.\nUse :stepmodule.")+ Just loc -> do+ md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule+ current_toplevel_decl <- flip enclosingTickSpan loc <$> getTickArray md+ doContinue (GHC.LocalStep (RealSrcSpan current_toplevel_decl Strict.Nothing))++stepModuleCmd :: GhciMonad m => String -> m ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+ where+ step expr+ | not (null expr) = stepCmd expr+ | otherwise = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing -> stepCmd []+ Just pan -> doContinue (GHC.ModuleStep pan)++traceCmd :: GhciMonad m => String -> m ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue GHC.RunAndLogSteps+ tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: GhciMonad m => String -> m () -- #19157+continueCmd argLine = withSandboxOnly ":continue" $+ case contSwitch (words argLine) of+ Left sdoc -> printForUser sdoc+ Right mbCnt -> doContinue' GHC.RunToCompletion mbCnt+ where+ contSwitch :: [String] -> Either SDoc (Maybe Int)+ contSwitch [ ] = Right Nothing+ contSwitch [x] = Just <$> getIgnoreCount x+ contSwitch _ = Left $+ text "After ':continue' only one ignore count is allowed"++doContinue :: GhciMonad m => SingleStep -> m ()+doContinue step = doContinue' step Nothing++doContinue' :: GhciMonad m => SingleStep -> Maybe Int -> m ()+doContinue' step mbCnt= do+ runResult <- resume step mbCnt+ _ <- afterRunStmt step runResult+ return ()++abandonCmd :: GhciMonad m => String -> m ()+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do+ b <- GHC.abandon -- the prompt will change to indicate the new context+ when (not b) $ liftIO $ putStrLn "There is no computation running."++deleteCmd :: GhciMonad m => String -> m ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+ deleteSwitch $ words argLine+ where+ deleteSwitch :: GhciMonad m => [String] -> m ()+ deleteSwitch [] =+ liftIO $ putStrLn "The delete command requires at least one argument."+ -- delete all break points+ deleteSwitch ("*":_rest) = discardActiveBreakPoints+ deleteSwitch idents = do+ mapM_ deleteOneBreak idents+ where+ deleteOneBreak :: GhciMonad m => String -> m ()+ deleteOneBreak str+ | all isDigit str = deleteBreak (read str)+ | otherwise = return ()++enableCmd :: GhciMonad m => String -> m ()+enableCmd argLine = withSandboxOnly ":enable" $ do+ enaDisaSwitch True $ words argLine++disableCmd :: GhciMonad m => String -> m ()+disableCmd argLine = withSandboxOnly ":disable" $ do+ enaDisaSwitch False $ words argLine++enaDisaSwitch :: GhciMonad m => Bool -> [String] -> m ()+enaDisaSwitch enaDisa [] =+ printForUser (text "The" <+> text strCmd <+>+ text "command requires at least one argument.")+ where+ strCmd = if enaDisa then ":enable" else ":disable"+enaDisaSwitch enaDisa ("*" : _) = enaDisaAllBreaks enaDisa+enaDisaSwitch enaDisa idents = do+ mapM_ (enaDisaOneBreak enaDisa) idents+ where+ enaDisaOneBreak :: GhciMonad m => Bool -> String -> m ()+ enaDisaOneBreak enaDisa strId = do+ sdoc_loc <- checkEnaDisa enaDisa strId+ case sdoc_loc of+ Left sdoc -> printForUser sdoc+ Right loc -> enaDisaAssoc enaDisa (read strId, loc)++checkEnaDisa :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)+checkEnaDisa enaDisa strId = do+ sdoc_loc <- getBreakLoc strId+ pure $ sdoc_loc >>= checkEnaDisaState enaDisa strId++getBreakLoc :: GhciMonad m => String -> m (Either SDoc BreakLocation)+getBreakLoc strId = do+ st <- getGHCiState+ case readMaybe strId >>= flip IntMap.lookup (breaks st) of+ Nothing -> return $ Left (text "Breakpoint" <+> text strId <+>+ text "not found")+ Just loc -> return $ Right loc++checkEnaDisaState :: Bool -> String -> BreakLocation -> Either SDoc BreakLocation+checkEnaDisaState enaDisa strId loc = do+ if breakEnabled loc == enaDisa+ then Left $+ text "Breakpoint" <+> text strId <+> text "already in desired state"+ else Right loc++enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m ()+enaDisaAssoc enaDisa (intId, loc) = do+ st <- getGHCiState+ newLoc <- turnBreakOnOff enaDisa loc+ let new_breaks = IntMap.insert intId newLoc (breaks st)+ setGHCiState $ st { breaks = new_breaks }++enaDisaAllBreaks :: GhciMonad m => Bool -> m()+enaDisaAllBreaks enaDisa = do+ st <- getGHCiState+ mapM_ (enaDisaAssoc enaDisa) $ IntMap.assocs $ breaks st++historyCmd :: GHC.GhcMonad m => String -> m ()+historyCmd arg+ | null arg = history 20+ | all isDigit arg = history (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"+ where+ history num = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+ (r:_) -> do+ let hist = GHC.resumeHistory r+ (took,rest) = splitAt num hist+ case hist of+ [] -> liftIO $ putStrLn $+ "Empty history. Perhaps you forgot to use :trace?"+ _ -> do+ pans <- mapM GHC.getHistorySpan took+ let nums = map (printf "-%-3d:") [(1::Int)..]+ names = map GHC.historyEnclosingDecls took+ printForUser (vcat(zipWith3+ (\x y z -> x <+> y <+> z)+ (map text nums)+ (map (bold . hcat . punctuate colon . map text) names)+ (map (parens . ppr) pans)))+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold = text start_bold <> c <> text end_bold+ | otherwise = c++ignoreCmd :: GhciMonad m => String -> m () -- #19157+ignoreCmd argLine = withSandboxOnly ":ignore" $ do+ result <- ignoreSwitch (words argLine)+ case result of+ Left sdoc -> printForUser sdoc+ Right (loc, count) -> do+ setupBreakpoint (breakId loc) count++ignoreSwitch :: GhciMonad m => [String] -> m (Either SDoc (BreakLocation, Int))+ignoreSwitch [break, count] = do+ sdoc_loc <- getBreakLoc break+ pure $ (,) <$> sdoc_loc <*> getIgnoreCount count+ignoreSwitch _ = pure $ Left $ text "Syntax: :ignore <breaknum> <count>"++getIgnoreCount :: String -> Either SDoc Int+getIgnoreCount str =+ case readMaybe str of+ Nothing -> Left $ sdocIgnore <+> "is not numeric"+ Just cnt | cnt < 0 -> Left $ sdocIgnore <+> "must be >= 0"+ | otherwise -> Right cnt+ where+ sdocIgnore = text "Ignore count" <+> quotes (text str)++setupBreakpoint :: GhciMonad m => GHC.BreakpointId -> Int -> m ()+setupBreakpoint bi count = do+ hsc_env <- GHC.getSession+ -- Trigger all internal breaks that match this source break id+ internal_break_ids <- getInternalBreaksOf bi+ forM_ internal_break_ids $ \ibi -> do+ GHC.setupBreakpoint (hscInterp hsc_env) ibi count++backCmd :: GhciMonad m => String -> m ()+backCmd arg+ | null arg = back 1+ | all isDigit arg = back (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :back [num]"+ where+ back num = withSandboxOnly ":back" $ do+ (names, _, pan) <- GHC.back num+ printForUser $ text "Logged breakpoint at" <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++forwardCmd :: GhciMonad m => String -> m ()+forwardCmd arg+ | null arg = forward 1+ | all isDigit arg = forward (read arg)+ | otherwise = liftIO $ putStrLn "Syntax: :forward [num]"+ where+ forward num = withSandboxOnly ":forward" $ do+ (names, ix, pan) <- GHC.forward num+ printForUser $ (if (ix == 0)+ then text "Stopped at"+ else text "Logged breakpoint at") <+> ppr pan+ printTypeOfNames names+ -- run the command set with ":set stop <cmd>"+ st <- getGHCiState+ enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: GhciMonad m => String -> m ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: GhciMonad m => [String] -> m ()+breakSwitch [] = do+ liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+ | looksLikeModuleName arg1 && not (null rest) = do+ md <- wantInterpretedModule arg1+ breakByModule md rest+ | all isDigit arg1 = do+ imports <- GHC.getContext+ case iiModules imports of+ (md : _) -> do+ breakByModuleLine md (read arg1) rest+ [] -> do+ liftIO $ putStrLn "No modules are loaded with debugging support."+ | otherwise = do -- try parsing it as an identifier+ breakById arg1++breakByModule :: GhciMonad m => Module -> [String] -> m ()+breakByModule md (arg1:rest)+ | all isDigit arg1 = do -- looks like a line number+ breakByModuleLine md (read arg1) rest+breakByModule _ _+ = breakSyntax++breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()+breakByModuleLine md line args+ | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line+ | [col] <- args, all isDigit col =+ findBreakAndSet md $ maybeToList . findBreakByCoord (line, read col)+ | otherwise = breakSyntax++-- Set a breakpoint for an identifier+-- See Note [Setting Breakpoints by Id]+breakById :: GhciMonad m => String -> m () -- #3000+breakById inp = do+ mb_error <- resolveFunctionBreakpoint inp+ case mb_error of+ Left sdoc -> printForUser sdoc+ Right (mod, mod_info, fun_str) -> do+ let modBreaks = expectJust (GHC.modInfoModBreaks mod_info)+ findBreakAndSet mod $ \_ -> findBreakForBind fun_str (imodBreaks_modBreaks modBreaks)++breakSyntax :: a+breakSyntax = throwGhcException $ CmdLineError ("Syntax: :break [<mod>.]<func>[.<func>]\n"+ ++ " :break [<mod>] <line> [<column>]")++findBreakAndSet :: GhciMonad m+ => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()+findBreakAndSet md lookupTickTree = do+ tickArray <- getTickArray md+ case lookupTickTree tickArray of+ [] -> liftIO $ putStrLn $ "No breakpoints found at that location."+ some -> mapM_ breakAt some+ where+ breakAt (tick, pan) = do+ let bi = BreakpointId md tick+ setBreakFlag bi True+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakLoc = RealSrcSpan pan Strict.Nothing+ , breakId = bi+ , onBreakCmd = ""+ , breakEnabled = True+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+ where mTerm = System.Environment.getEnv "TERM"+ `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold = "\ESC[0m"++{-+Note [Setting Breakpoints by Id]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To set a breakpoint first check whether a ModBreaks array contains a+breakpoint with the given function name:+In `:break M.foo` `M` may be a module name or a local alias of an import+statement. To lookup a breakpoint in the ModBreaks, the effective module+name is needed. Even if a module called `M` exists, `M` may still be+a local alias. To get the module name, parse the top-level identifier with+`GHC.parseName`. If this succeeds, extract the module name from the+returned value. If it fails, catch the exception and assume `M` is a real+module name.++The names of nested functions are stored in `ModBreaks.modBreaks_decls`.+-}++-----------------------------------------------------------------------------+-- :where++whereCmd :: GHC.GhcMonad m => String -> m ()+whereCmd = noArgs $ do+ mstrs <- getCallStackAtCurrentBreakpoint+ case mstrs of+ Nothing -> return ()+ Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: GhciMonad m => String -> m ()+listCmd "" = do+ mb_span <- getCurrentBreakSpan+ case mb_span of+ Nothing ->+ printForUser $ text "Not stopped at a breakpoint; nothing to list"+ Just (RealSrcSpan pan _) ->+ listAround pan True+ Just pan@(UnhelpfulSpan _) ->+ do resumes <- GHC.getResumeContext+ case resumes of+ [] -> panic "No resumes"+ (r:_) ->+ do let traceIt = case GHC.resumeHistory r of+ [] -> text "rerunning with :trace,"+ _ -> empty+ doWhat = traceIt <+> text ":back then :list"+ printForUser (text "Unable to list source for" <+>+ ppr pan+ $$ text "Try" <+> doWhat)+listCmd str = list2 (words str)++list2 :: GhciMonad m => [String] -> m ()+list2 [arg] | all isDigit arg = do+ imports <- GHC.getContext+ case iiModules imports of+ [] -> liftIO $ putStrLn "No module to list"+ (mn : _) -> do+ listModuleLine mn (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+ md <- wantInterpretedModule arg1+ listModuleLine md (read arg2)+list2 [arg] = do+ wantNameFromInterpretedModule noCanDo arg $ \name -> do+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+ case loc of+ RealSrcLoc l _ ->+ do tickArray <- assert (isExternalName name) $+ getTickArray (GHC.nameModule name)+ let mb_span = findBreakByCoord+ (GHC.srcLocLine l, GHC.srcLocCol l)+ tickArray+ case mb_span of+ Nothing -> listAround (realSrcLocSpan l) False+ Just (_, pan) -> listAround pan False+ UnhelpfulLoc _ ->+ noCanDo name $ text "can't find its location: " <>+ ppr loc+ where+ noCanDo n why = printForUser $+ text "cannot list source code for " <> ppr n <> text ": " <> why+list2 _other =+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()+listModuleLine modl line = do+ graph <- GHC.getModuleGraph+ let this = GHC.mgLookupModule graph modl+ case this of+ Just (GHC.ModuleNodeCompile summ) -> do+ let filename = expectJust (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++ _ -> panic "listModuleLine"++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 2) convert the BS to String using utf-string, and write it out.+-- It would be better if we could convert directly between UTF-8 and the+-- console encoding, of course.+listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()+listAround pan do_highlight = do+ contents <- liftIO $ BS.readFile (unpackFS file)+ -- Drop carriage returns to avoid duplicates, see #9367.+ let ls = BS.split '\n' $ BS.filter (/= '\r') contents+ ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+ drop (line1 - 1 - pad_before) $ ls+ fst_line = max 1 (line1 - pad_before)+ line_nos = [ fst_line .. ]++ highlighted | do_highlight = zipWith highlight line_nos ls'+ | otherwise = [\p -> BS.concat[p,l] | l <- ls']++ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]+ prefixed = zipWith ($) highlighted bs_line_nos+ output = BS.intercalate (BS.pack "\n") prefixed++ let utf8Decoded = utf8DecodeByteString output+ liftIO $ putStrLn utf8Decoded+ where+ file = GHC.srcSpanFile pan+ line1 = GHC.srcSpanStartLine pan+ col1 = GHC.srcSpanStartCol pan - 1+ line2 = GHC.srcSpanEndLine pan+ col2 = GHC.srcSpanEndCol pan - 1++ pad_before | line1 == 1 = 0+ | otherwise = 1+ pad_after = 1++ highlight | do_bold = highlight_bold+ | otherwise = highlight_carets++ highlight_bold no line prefix+ | no == line1 && no == line2+ = let (a,r) = BS.splitAt col1 line+ (b,c) = BS.splitAt (col2-col1) r+ in+ BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+ | no == line1+ = let (a,b) = BS.splitAt col1 line in+ BS.concat [prefix, a, BS.pack start_bold, b]+ | no == line2+ = let (a,b) = BS.splitAt col2 line in+ BS.concat [prefix, a, BS.pack end_bold, b]+ | otherwise = BS.concat [prefix, line]++ highlight_carets no line prefix+ | no == line1 && no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+ BS.replicate (col2-col1) '^']+ | no == line1+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+ prefix, line]+ | no == line2+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+ BS.pack "^^"]+ | otherwise = BS.concat [prefix, line]+ where+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')+ nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: GhciMonad m => Module -> m TickArray+getTickArray modl = do+ st <- getGHCiState+ let arrmap = tickarrays st+ case lookupModuleEnv arrmap modl of+ Just arr -> return arr+ Nothing -> do+ arr <- fromMaybe (panic "getTickArray") <$> makeModuleLineMap modl+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GhciMonad m => m ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GhciMonad m => m ()+discardActiveBreakPoints = do+ st <- getGHCiState+ mapM_ (turnBreakOnOff False) $ breaks st+ setGHCiState $ st { breaks = IntMap.empty }++discardInterfaceCache :: GhciMonad m => m ()+discardInterfaceCache =+ void (liftIO . iface_clearCache . ifaceCache =<< getGHCiState)++clearHPTs :: GhciMonad m => m ()+clearHPTs = do+ let pruneHomeUnitEnv hme = liftIO $ do+ emptyHpt <- emptyHomePackageTable+ pure hme{ homeUnitEnv_hpt = emptyHpt }+ discardMG hsc = setModuleGraph GHC.emptyMG hsc+ modifySessionM $ \hsc_env -> do+ hug' <- traverse pruneHomeUnitEnv $ hsc_HUG hsc_env+ pure $ discardMG $ discardIC $ hscUpdateHUG (const hug') hsc_env++-- The unused package warning doesn't make sense once the targets get out of+-- sync with the package flags. See #21110+-- Therefore if it's turned on, the warnings are issued until the module context+-- changes (via :load or :cd), at which stage the package flags are not going to change+-- but the loaded modules will probably not use all the specified packages so the+-- warning becomes spurious. At that point the warning is silently disabled.+disableUnusedPackages :: GhciMonad m => m ()+disableUnusedPackages = newDynFlags False ["-Wno-unused-packages"]++deleteBreak :: GhciMonad m => Int -> m ()+deleteBreak identity = do+ st <- getGHCiState+ let oldLocations = breaks st+ case IntMap.lookup identity oldLocations of+ Nothing -> printForUser (text "Breakpoint" <+> ppr identity <+>+ text "does not exist")+ Just loc -> do+ _ <- (turnBreakOnOff False) loc+ let rest = IntMap.delete identity oldLocations+ setGHCiState $ st { breaks = rest }++turnBreakOnOff :: GhciMonad m => Bool -> BreakLocation -> m BreakLocation+turnBreakOnOff onOff loc+ | onOff == breakEnabled loc = return loc+ | otherwise = do+ setBreakFlag (breakId loc) onOff+ return loc { breakEnabled = onOff }++setBreakFlag :: GhciMonad m => GHC.BreakpointId -> Bool -> m ()+setBreakFlag (BreakpointId md ix) enaDisa = do+ let enaDisaToCount True = breakOn+ enaDisaToCount False = breakOff+ setupBreakpoint (BreakpointId md ix) $ enaDisaToCount enaDisa++-- --------------------------------------------------------------------------+-- Find matching Internal Breakpoints++-- | Find all the internal breakpoints that use the given source-level breakpoint id+getInternalBreaksOf :: GhciMonad m => BreakpointId -> m [InternalBreakpointId]+getInternalBreaksOf bi = do+ st <- getGHCiState+ let ibrks = internalBreaks st+ case lookupBreakpointOccurrences ibrks bi of+ Just bs -> return bs+ Nothing -> do+ -- Refresh the internal breakpoints map+ bs <- mkBreakpointOccurrences+ setGHCiState st{internalBreaks = bs}+ return $+ fromMaybe [] {- still not found after refresh -} $+ lookupBreakpointOccurrences bs bi++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception. The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- raising another exception. We therefore don't put the recursive+-- handler around the flushing operation, so if stderr is closed+-- GHCi will just die gracefully rather than going into an infinite loop.+handler :: GhciMonad m => SomeException -> m Bool+handler exception = do+ flushInterpBuffers+ withSignalHandlers $+ ghciHandle handler (showException exception >> return False)++showException :: MonadIO m => SomeException -> m ()+showException se =+ liftIO $ case fromException se of+ -- omit the location for CmdLineError:+ Just (CmdLineError s) -> putException s+ -- ditto:+ Just other_ghc_ex -> putException (show other_ghc_ex)+ Nothing ->+ case fromException se of+ Just (GhciCommandError s) -> putException (show (GhciCommandError s))+ Nothing ->+ case fromException se of+ Just UserInterrupt -> putException "Interrupted."+ _ -> putException ("*** Exception: " ++ show se)+ where+ putException = hPutStrLn stderr++failIfExprEvalMode :: GhciMonad m => m ()+failIfExprEvalMode = do+ s <- getGHCiState+ when (ghc_e s) $+ liftIO (exitWith (ExitFailure 1))++-- | When in expression evaluation mode (ghc -e), we want to exit immediately.+-- Otherwis, just print out the message.+printErrAndMaybeExit :: (GhciMonad m, MonadIO m, HasLogger m) => SourceError -> m ()+printErrAndMaybeExit err = printGhciException err >> failIfExprEvalMode++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered. Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasLogger m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = mask $ \restore -> do+ -- Force dflags to avoid leaking the associated HscEnv+ !log <- getLogger+ catch (restore (GHC.prettyPrintGhcErrors log m)) $ \e -> restore (h e)++ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)+ghciTry m = fmap Right m `catch` \e -> return $ Left e++tryBool :: ExceptionMonad m => m a -> m Bool+tryBool m = do+ r <- ghciTry m+ case r of+ Left _ -> return False+ Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName++lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module+lookupQualifiedModuleName qual modl = do+ GHC.lookupAllQualifiedModuleNames qual modl >>= \case+ [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl)+ [m] -> pure m+ ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms)++lookupHomeUnitModuleName :: GHC.GhcMonad m => GHC.ModuleGraph -> ModuleName -> m HomeUnitModule+lookupHomeUnitModuleName mod_graph modl = do+ m <- case GHC.mgLookupModuleName mod_graph (GWIB modl GHC.NotBoot) of+ [] -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl)+ [m] -> pure $ GHC.moduleNodeInfoModule m+ ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl (map GHC.moduleNodeInfoModule ms))++ if unitIsDefinite (moduleUnit m)+ then pure (fmap toUnitId m)+ else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit"))+ where+ str = moduleNameString modl++showModule :: Module -> String+showModule = moduleNameString . moduleName++-- Return a String with the declPath of the function of a breakpoint.+-- See Note [Field modBreaks_decls] in GHC.ByteCode.Types+declPath :: [String] -> String+declPath = intercalate "."++-- | Optionally show a fixity declaration like @infixr 4 #@+--+-- We always display the fixity of terms with symbolic names (like <$>).+-- For other terms we only display the fixity if it has been set to a+-- value other than the default infixl 9.+--+-- We have no way of distinguishing between a fixity that has been+-- manually set to infixl 9 and a fixity that has assumed infixl 9 as+-- the default, so we choose to not display the fixity in both cases+-- (for terms with non-symbolic names).+--+-- See #19200.+showFixity :: TyThing -> Fixity -> SDoc+showFixity thing fixity+ | fixity /= GHC.defaultFixity || isSymOcc (getOccName thing)+ = ppr fixity <+> pprInfixName (GHC.getName thing)+ | otherwise = empty++-- TODO: won't work if home dir is encoded.+-- (changeDirectory may not work either in that case.)+expandPath :: MonadIO m => String -> m String+expandPath = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+ case dropWhile isSpace p of+ ('~':d) -> do+ tilde <- getHomeDirectory -- will fail if HOME not defined+ return (tilde ++ '/':d)+ other ->+ return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+ modl <- lookupModuleName modname+ checkInterpretedModule modl++checkInterpretedModule :: GHC.GhcMonad m => Module -> m Module+checkInterpretedModule modl = do+ let str = moduleNameString $ moduleName modl+ hug <- hsc_HUG <$> GHC.getSession+ unless (HUG.memberHugUnit (moduleUnit modl) hug) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+ is_interpreted <- GHC.moduleIsInterpreted modl+ when (not is_interpreted) $+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+ return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+ => (Name -> SDoc -> m ())+ -> String+ -> (Name -> m ())+ -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+ handleSourceError printGhciException $ do+ n NE.:| _ <- GHC.parseName str+ let modl = assert (isExternalName n) $ GHC.nameModule n+ if not (GHC.isExternalName n)+ then noCanDo n $ ppr n <>+ text " is not defined in an interpreted module"+ else do+ is_interpreted <- GHC.moduleIsInterpreted modl+ if not is_interpreted+ then noCanDo n $ text "module " <> ppr modl <>+ text " is not interpreted"+ else and_then n++clearCaches :: GhciMonad m => m ()+clearCaches = discardActiveBreakPoints+ >> discardInterfaceCache+ >> disableUnusedPackages+ >> clearHPTs
+ src-bin-9.14/Clash/GHCi/UI/Exception.hs view
@@ -0,0 +1,566 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Clash.GHCi.UI.Exception+ ( GhciCommandError(..)+ , throwGhciCommandError+ , handleGhciCommandError+ , GhciMessage(..)+ , GhciMessageOpts(..)+ , fromGhcOpts+ , toGhcHint+ , GhciCommandMessage(..)+ , GhciMacroError(..)+ , GhciModuleError(..)+ , InvalidMacroStart(..)+ , GHCi+ ) where++import GHC.Prelude++import GHC.Driver.Errors.Types++import GHC.Iface.Errors.Ppr+import GHC.Iface.Errors.Types++import qualified GHC.LanguageExtensions as LangExt++import GHC.Tc.Errors.Ppr+import GHC.Tc.Errors.Types++import GHC.Types.Error.Codes+import GHC.Types.SrcLoc (interactiveSrcSpan)+import GHC.TypeLits++import GHC.Unit.State++import GHC.Utils.Outputable+import GHC.Utils.Error++import GHC.Generics+import GHC.Types.Error+import GHC.Types+import qualified GHC++import Control.Exception+import Control.Monad.Catch as MC (MonadCatch, catch)+import Control.Monad.IO.Class+import Data.List.NonEmpty (NonEmpty(..))++-- | A 'GhciCommandError' are messages that caused the abortion of a GHCi command.+newtype GhciCommandError = GhciCommandError (Messages GhciMessage)++instance Exception GhciCommandError++instance Show GhciCommandError where+ -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics+ -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions.+ -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'.+ show (GhciCommandError msgs) =+ renderWithContext defaultSDocContext+ . vcat+ . pprMsgEnvelopeBagWithLocDefault+ . getMessages+ $ msgs++-- | Perform the given action and call the exception handler if the action+-- throws a 'GhciCommandError'. See 'GhciCommandError' for more information.+handleGhciCommandError :: (MonadCatch m) =>+ (GhciCommandError -> m a) -- ^ exception handler+ -> m a -- ^ action to perform+ -> m a+handleGhciCommandError handler act =+ MC.catch act (\(e :: GhciCommandError) -> handler e)++throwGhciCommandError :: MonadIO m => GhciCommandMessage -> m a+throwGhciCommandError errorMessage =+ liftIO+ . throwIO+ . GhciCommandError+ . singleMessage+ $ mkPlainErrorMsgEnvelope interactiveSrcSpan (GhciCommandMessage errorMessage)++-- | The Options passed to 'diagnosticMessage'+-- in the 'Diagnostic' instance of 'GhciMessage'.+data GhciMessageOpts = GhciMessageOpts+ { ghcMessageOpts :: DiagnosticOpts GhcMessage+ , ghciCommandMessageOpts :: DiagnosticOpts GhciCommandMessage+ }++-- | A 'GhciMessage' may either be a message that GHC emitted ('GhciGhcMessage'),+-- a message that is specific to GHCi ('GhciCommandMessage'),+-- or an external message ('GhciUnknownMessage') that can be used by external tools.+data GhciMessage where+ GhciCommandMessage :: GhciCommandMessage -> GhciMessage+ GhciGhcMessage :: GhcMessage -> GhciMessage+ GhciUnknownMessage :: UnknownDiagnosticFor GhciMessage -> GhciMessage++-- | A 'GhciHint' may either be a hint that GHC emitted ('GhciGhcHint')+-- or one that is specific to GHCi ('GhciCommandHint').+data GhciHint where+ GhciCommandHint :: GhciCommandHint -> GhciHint+ GhciGhcHint :: GhcHint -> GhciHint++-- | If this is a contained 'GhcHint' simply unwrap it,+-- otherwise use 'GhcHint's 'UnknownHint' constructor.+toGhcHint :: GhciHint -> GhcHint+toGhcHint (GhciGhcHint h) = h+toGhcHint (GhciCommandHint h) = UnknownHint h++instance Outputable GhciHint where+ ppr = \case+ GhciCommandHint hint -> ppr hint+ GhciGhcHint hint -> ppr hint++instance HasDefaultDiagnosticOpts GhciMessageOpts where+ defaultOpts = GhciMessageOpts+ (defaultDiagnosticOpts @GhcMessage)+ (defaultDiagnosticOpts @GhciCommandMessage)++-- | Create default 'GhciMessageOpts' but embed the given 'GhcMessageOpts'+fromGhcOpts :: DiagnosticOpts GhcMessage -> DiagnosticOpts GhciMessage+fromGhcOpts ghc_opts = defaultOpts { ghcMessageOpts = ghc_opts }++instance Diagnostic GhciMessage where+ type DiagnosticOpts GhciMessage = GhciMessageOpts+ type DiagnosticHint GhciMessage = GhciHint++ diagnosticMessage opts = \case+ GhciGhcMessage m -> ghciDiagnosticMessage (ghcMessageOpts opts) m+ GhciCommandMessage m -> diagnosticMessage (ghciCommandMessageOpts opts) m+ GhciUnknownMessage (UnknownDiagnostic f _ m)+ -> diagnosticMessage (f opts) m++ diagnosticReason = \case+ GhciGhcMessage m -> diagnosticReason m+ GhciCommandMessage m -> diagnosticReason m+ GhciUnknownMessage m -> diagnosticReason m++ diagnosticHints = \case+ GhciGhcMessage m -> map GhciGhcHint (ghciDiagnosticHints m)+ GhciCommandMessage m -> map GhciCommandHint (diagnosticHints m)+ GhciUnknownMessage m -> diagnosticHints m++ diagnosticCode = \case+ GhciGhcMessage m -> diagnosticCode m+ GhciCommandMessage m -> diagnosticCode m+ GhciUnknownMessage m -> diagnosticCode m+++-- | Modifications to hint messages which we want to display in GHCi.+ghciDiagnosticHints :: GhcMessage -> [GhcHint]+ghciDiagnosticHints msg = map modifyHintForGHCi (diagnosticHints msg)+ where+ modifyHintForGHCi :: GhcHint -> GhcHint+ modifyHintForGHCi = \case+ SuggestExtension extHint -> SuggestExtension $ modifyExtHintForGHCi extHint+ hint -> hint+ modifyExtHintForGHCi :: LanguageExtensionHint -> LanguageExtensionHint+ modifyExtHintForGHCi = \case+ SuggestSingleExtension doc ext -> SuggestSingleExtension (suggestSetExt [ext] doc False) ext+ SuggestExtensionInOrderTo doc ext -> SuggestExtensionInOrderTo (suggestSetExt [ext] doc False) ext+ SuggestAnyExtension doc exts -> SuggestAnyExtension (suggestSetExt exts doc True ) exts+ SuggestExtensions doc exts -> SuggestExtensions (suggestSetExt exts doc False) exts+ -- Suggest enabling extension with :set -X<ext>+ -- SuggestAnyExtension will be on multiple lines so the user can select which to enable without editing+ suggestSetExt :: [LangExt.Extension] -> SDoc -> Bool -> SDoc+ suggestSetExt exts doc enable_any = doc $$ hang header 2 exts_cmds+ where+ header = text "You may enable" <+> which <+> text "language extension" <> plural exts <+> text "in GHCi with:"+ which+ | [ _ext ] <- exts+ = text "this"+ | otherwise+ = if enable_any+ then text "these"+ else text "all of these"+ exts_cmds+ | enable_any+ = vcat $ map (\ext -> text ":set -X" <> ppr ext) exts+ | otherwise+ = text ":set" <> hcat (map (\ext -> text " -X" <> ppr ext) exts)++-- | Modifications to error messages which we want to display in GHCi+ghciDiagnosticMessage :: GhcMessageOpts -> GhcMessage -> DecoratedSDoc+ghciDiagnosticMessage ghc_opts msg =+ case msg of+ GhcTcRnMessage tc_msg ->+ case tcRnMessage (tcMessageOpts ghc_opts) tc_msg of+ Nothing -> diagnosticMessage ghc_opts msg+ Just sdoc -> sdoc+ GhcDriverMessage (DriverInterfaceError err) ->+ case ghciInterfaceError err of+ Just sdoc -> mkSimpleDecorated sdoc+ Nothing -> diagnosticMessage ghc_opts msg+ GhcDriverMessage {} -> diagnosticMessage ghc_opts msg+ GhcPsMessage {} -> diagnosticMessage ghc_opts msg+ GhcDsMessage {} -> diagnosticMessage ghc_opts msg+ GhcUnknownMessage {} -> diagnosticMessage ghc_opts msg+ where+ tcRnMessage tc_opts tc_msg =+ case tc_msg of+ TcRnInterfaceError err -> mkSimpleDecorated <$> (ghciInterfaceError err)+ TcRnMessageWithInfo unit_state msg_with_info ->+ case msg_with_info of+ TcRnMessageDetailed err_info wrapped_msg+ -> messageWithInfoDiagnosticMessage unit_state err_info+ (tcOptsShowContext tc_opts)+ <$> tcRnMessage tc_opts wrapped_msg+ TcRnWithHsDocContext ctxt wrapped_msg ->+ messageWithHsDocContext tc_opts ctxt <$> tcRnMessage tc_opts wrapped_msg+ _ -> Nothing++ opts = tcOptsIfaceOpts (tcMessageOpts ghc_opts)++ ghciInterfaceError (Can'tFindInterface err looking_for) =+ hangNotEmpty (lookingForHerald looking_for) 2 <$> ghciMissingInterfaceErrorDiagnostic err+ ghciInterfaceError _ = Nothing++ ghciMissingInterfaceErrorDiagnostic reason =+ case reason of+ CantFindErr us module_or_interface cfi ->+ Just (pprWithUnitState us $ cantFindErrorX pkg_hidden_hint may_show_locations module_or_interface cfi)+ _ -> Nothing+ where++ may_show_locations = mayShowLocations ":set -v" (ifaceShowTriedFiles opts)++ pkg_hidden_hint = pkgHiddenHint hidden_msg (ifaceBuildingCabalPackage opts)+ where+ hidden_msg pkg =+ text "You can run" <+>+ quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>+ text "to expose it." $$+ text "(Note: this unloads all the modules in the current scope.)"+++data InvalidMacroStart = Colon | ExclamationMark++instance Outputable InvalidMacroStart where+ ppr = \case+ Colon+ -> "a colon"+ ExclamationMark+ -> "an exclamation mark"++data GhciMacroError+ = GhciMacroAlreadyDefined String+ | GhciMacroInvalidStart String InvalidMacroStart+ | GhciMacroNotDefined String+ | GhciMacroOverwritesBuiltin String+ deriving Generic++instance Diagnostic GhciMacroError where+ type DiagnosticOpts GhciMacroError = NoDiagnosticOpts+ type DiagnosticHint GhciMacroError = GhciCommandHint++ diagnosticMessage NoDiagnosticOpts = mkSimpleDecorated . \case+ GhciMacroAlreadyDefined name+ -> macro name "is already defined"+ GhciMacroInvalidStart name invStart+ -> macro name ("cannot start with" <+> ppr invStart)+ GhciMacroNotDefined name+ -> macro name "is not defined"+ GhciMacroOverwritesBuiltin name+ -> macro name "overwrites builtin command"+ where macro name what = "Macro" <+> quotes (text name) <+> what++ diagnosticReason = \case+ GhciMacroAlreadyDefined{}+ -> ErrorWithoutFlag+ GhciMacroInvalidStart{}+ -> ErrorWithoutFlag+ GhciMacroNotDefined{}+ -> ErrorWithoutFlag+ GhciMacroOverwritesBuiltin{}+ -> ErrorWithoutFlag++ diagnosticHints = \case+ GhciMacroAlreadyDefined{}+ -> [SuggestOverwrite]+ GhciMacroInvalidStart{}+ -> []+ GhciMacroNotDefined{}+ -> []+ GhciMacroOverwritesBuiltin{}+ -> [SuggestOverwrite]++ diagnosticCode = constructorCode @GHCi++data GhciModuleError+ = GhciModuleNotFound String+ | GhciNoModuleNameGuess+ | GhciNoModuleInfoForCurrentFile+ | GhciNoLocationInfoForModule GHC.ModuleName+ | GhciNoResolvedModules+ | GhciNoModuleForName GHC.Name+ | GhciNoMatchingModuleExport+ | GhciNoLocalModuleName !GHC.ModuleName+ | GhciModuleNameNotFound !GHC.ModuleName+ | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module]+ deriving Generic++instance Diagnostic GhciModuleError where+ type DiagnosticOpts GhciModuleError = NoDiagnosticOpts+ type DiagnosticHint GhciModuleError = GhciCommandHint++ diagnosticMessage NoDiagnosticOpts = mkSimpleDecorated . \case+ GhciModuleNotFound modN+ -> "Module" <+> text modN <+> "not found"+ GhciNoModuleNameGuess+ -> "Couldn't guess that module name. Does it exist?"+ GhciNoModuleInfoForCurrentFile+ -> "No module info for current file! Try loading it?"+ GhciNoLocationInfoForModule name+ -> "Found a name, but no location information" <> dot <+> "The module is" <> colon <+> ppr name+ GhciNoResolvedModules+ -> "Couldn't resolve to any modules."+ GhciNoModuleForName name+ -> "No module for" <+> ppr name+ GhciNoMatchingModuleExport+ -> "No matching export in any local modules."+ GhciNoLocalModuleName modl+ -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally"+ GhciModuleNameNotFound modl+ -> "module" <+> quotes (ppr modl) <+> "could not be found."+ GhciAmbiguousModuleName modl candidates+ -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" $+$+ vcat+ [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m)+ | m <- candidates+ ]++ diagnosticReason = \case+ GhciModuleNotFound{} ->+ ErrorWithoutFlag+ GhciNoModuleNameGuess{} ->+ ErrorWithoutFlag+ GhciNoModuleInfoForCurrentFile{} ->+ ErrorWithoutFlag+ GhciNoLocationInfoForModule{} ->+ ErrorWithoutFlag+ GhciNoResolvedModules{} ->+ ErrorWithoutFlag+ GhciNoModuleForName{} ->+ ErrorWithoutFlag+ GhciNoMatchingModuleExport{} ->+ ErrorWithoutFlag+ GhciNoLocalModuleName{} ->+ ErrorWithoutFlag+ GhciModuleNameNotFound{} ->+ ErrorWithoutFlag+ GhciAmbiguousModuleName{} ->+ ErrorWithoutFlag++ diagnosticHints = \case+ GhciModuleNotFound{} ->+ []+ GhciNoModuleNameGuess{} ->+ []+ GhciNoModuleInfoForCurrentFile{} ->+ []+ GhciNoLocationInfoForModule{} ->+ []+ GhciNoResolvedModules{} ->+ []+ GhciNoModuleForName{} ->+ []+ GhciNoMatchingModuleExport{} ->+ []+ GhciNoLocalModuleName{} ->+ []+ GhciModuleNameNotFound{} ->+ []+ GhciAmbiguousModuleName{} ->+ []+ diagnosticCode = constructorCode @GHCi++-- | A Diagnostic emitted by GHCi while executing a command+-- these errors are assigned codes analogous to GHCs errors.+--+-- See 'GhciDiagnosticCode'.+data GhciCommandMessage+ -- module name errors+ = GhciMacroError GhciMacroError+ | GhciModuleError GhciModuleError+ -- others+ | GhciArgumentParseError SDoc+ | GhciCommandNotSupportedInMultiMode+ | GhciInvalidArgumentString String+ | GhciFileNotFound String+ | GhciCommandSyntaxError String+ | GhciInvalidPromptString+ | GhciPromptCallError String+ | GhciUnknownCommand String+ | GhciNoLastCommandAvailable+ | GhciUnknownFlag+ { ghciUnknownFlag :: !String+ , ghciUnknownFlagSuggestions :: [String]+ }+ | GhciNoSetEditor+ deriving Generic++-- | Hints that may be given by a 'GhciCommandMessage'+data GhciCommandHint+ = SuggestHelp+ | UseSetEditor+ | SuggestOverwrite+ | DidYouMean (NonEmpty String)++instance Outputable GhciCommandHint where+ ppr = \case+ SuggestHelp+ -> use "?" <+> "for help"+ DidYouMean (sugg :| rest)+ | [] <- rest -> "did you mean" <+> text sugg+ | otherwise -> "did you mean one of" <> colon <+> nest 2 (hsep (map text (sugg : rest)))+ UseSetEditor+ -> use "set editor"+ SuggestOverwrite+ -> use "def!" <+> "to overwrite"+ where use cmd = "Use" <+> quotes (colon <> cmd)++instance Diagnostic GhciCommandMessage where+ type DiagnosticOpts GhciCommandMessage = NoDiagnosticOpts+ type DiagnosticHint GhciCommandMessage = GhciCommandHint++ diagnosticMessage opts (GhciMacroError err) = diagnosticMessage opts err+ diagnosticMessage opts (GhciModuleError err) = diagnosticMessage opts err+ diagnosticMessage NoDiagnosticOpts err = mkSimpleDecorated $ case err of+ -- this can be improved with better/generic argument parsing+ GhciArgumentParseError ape+ -> ape+ GhciCommandNotSupportedInMultiMode+ -> "Command is not supported (yet) in multi-mode"+ -- In the future it would be better for toArgs to have a proper error type+ -- which could be used here and also help with reporting OPTIONS_GHC pragma errors better.+ GhciInvalidArgumentString str+ -> text str+ GhciCommandSyntaxError cmd+ -> "Syntax" <> colon $+$ nest 2 (colon <> text cmd)+ GhciInvalidPromptString+ -> "Can't parse prompt string. Use Haskell syntax"+ GhciUnknownCommand cmd+ -> "Unknown command" <+> quotes (colon <> text cmd)+ GhciNoLastCommandAvailable+ -> "There is no last command to perform"+ GhciFileNotFound f+ -> "File" <+> text f <+> "not found"+ GhciUnknownFlag { ghciUnknownFlag = flag }+ -> "Unrecognised flag" <> colon <+> text flag+ GhciPromptCallError err'+ -> "Error while calling prompt function" <> colon $$ nest 2 (quotes $ text err')+ GhciNoSetEditor+ -> "Editor not set"++ -- this might change in the future when we add more GHCi diagnostics+ diagnosticReason = \case+ GhciMacroError err+ -> diagnosticReason err+ GhciModuleError err+ -> diagnosticReason err+ GhciArgumentParseError{}+ -> ErrorWithoutFlag+ GhciCommandNotSupportedInMultiMode{}+ -> ErrorWithoutFlag+ GhciInvalidArgumentString{}+ -> ErrorWithoutFlag+ GhciFileNotFound {}+ -> ErrorWithoutFlag+ GhciCommandSyntaxError{}+ -> ErrorWithoutFlag+ GhciInvalidPromptString{}+ -> ErrorWithoutFlag+ GhciPromptCallError{}+ -> ErrorWithoutFlag+ GhciUnknownCommand{}+ -> ErrorWithoutFlag+ GhciNoLastCommandAvailable{}+ -> ErrorWithoutFlag+ GhciUnknownFlag{}+ -> ErrorWithoutFlag+ GhciNoSetEditor{}+ -> ErrorWithoutFlag++ diagnosticHints = \case+ GhciMacroError err+ -> diagnosticHints err+ GhciModuleError err+ -> diagnosticHints err+ GhciArgumentParseError{}+ -> []+ GhciCommandNotSupportedInMultiMode{}+ -> []+ GhciInvalidArgumentString{}+ -> []+ GhciFileNotFound{}+ -> []+ GhciCommandSyntaxError{}+ -> []+ GhciInvalidPromptString{}+ -> []+ GhciPromptCallError{}+ -> []+ GhciUnknownCommand{}+ -> [SuggestHelp]+ GhciNoLastCommandAvailable{}+ -> [SuggestHelp]+ GhciUnknownFlag { ghciUnknownFlagSuggestions = suggs }+ -> case suggs of+ [] -> []+ x:xs -> [DidYouMean (x :| xs)]+ GhciNoSetEditor{}+ -> [UseSetEditor]++ diagnosticCode = \case+ GhciMacroError err -> diagnosticCode err+ GhciModuleError err -> diagnosticCode err+ err -> constructorCode @GHCi err++-- | type index for the ghci diagnostic code namespace+data GHCi++instance DiagnosticCodeNameSpace GHCi where+ type instance NameSpaceTag GHCi = "GHCi"+ type instance DiagnosticCodeFor GHCi con = GhciDiagnosticCode con+ type instance ConRecursIntoFor GHCi con = GhciConRecursInto con++type GhciDiagnosticCode :: Symbol -> Nat+type family GhciDiagnosticCode c = n | n -> c where+ GhciDiagnosticCode "GhciCommandNotSupportedInMultiMode" = Outdated 83514+ GhciDiagnosticCode "GhciInvalidArgumentString" = 68894+ GhciDiagnosticCode "GhciCommandSyntaxError" = 72682+ GhciDiagnosticCode "GhciInvalidPromptString" = 50882+ GhciDiagnosticCode "GhciPromptCallError" = 22747+ GhciDiagnosticCode "GhciUnknownCommand" = 54713+ GhciDiagnosticCode "GhciNoLastCommandAvailable" = 29130+ GhciDiagnosticCode "GhciUnknownFlag" = 15670+ GhciDiagnosticCode "GhciNoSetEditor" = 34086+ GhciDiagnosticCode "GhciMacroInvalidStart" = 64996+ GhciDiagnosticCode "GhciMacroAlreadyDefined" = 93909+ GhciDiagnosticCode "GhciMacroNotDefined" = 40561+ GhciDiagnosticCode "GhciMacroOverwritesBuiltin" = 86201+ GhciDiagnosticCode "GhciFileNotFound" = 31901+ GhciDiagnosticCode "GhciModuleNotFound" = 23305+ GhciDiagnosticCode "GhciNoModuleNameGuess" = 21939+ GhciDiagnosticCode "GhciNoModuleInfoForCurrentFile" = 96587+ GhciDiagnosticCode "GhciNoLocationInfoForModule" = 12769+ GhciDiagnosticCode "GhciNoResolvedModules" = 54909+ GhciDiagnosticCode "GhciNoModuleForName" = 21847+ GhciDiagnosticCode "GhciNoMatchingModuleExport" = 59723+ GhciDiagnosticCode "GhciArgumentParseError" = 35671+ GhciDiagnosticCode "GhciNoLocalModuleName" = 81235+ GhciDiagnosticCode "GhciModuleNameNotFound" = 40475+ GhciDiagnosticCode "GhciAmbiguousModuleName" = 59019++type GhciConRecursInto :: Symbol -> Maybe Type+type family GhciConRecursInto con where+ GhciConRecursInto "GhciMacroError" = 'Just GhciMacroError+ GhciConRecursInto "GhciModuleError" = 'Just GhciModuleError+ GhciConRecursInto _ = 'Nothing
+ src-bin-9.14/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-warn-name-shadowing #-}++-- | Get information on modules, expressions, and identifiers+module Clash.GHCi.UI.Info+ ( ModInfo(..)+ , SpanInfo(..)+ , spanInfoFromRealSrcSpan+ , collectInfo+ , findLoc+ , findNameUses+ , findType+ , getModInfo+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.Catch as MC+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import Data.Data+import Data.Function+import Data.List (find, sortBy)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Time+import Prelude hiding (mod,(<>))+import System.Directory++import GHC.Hs.Syn.Type+import GHC.Driver.Session (HasDynFlags(..))+import GHC.Data.FastString+import GHC+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Ppr+import GHC.Types.Name+import GHC.Tc.Types+import GHC.Types.Name.Reader+import GHC.Types.Name.Set+import GHC.Utils.Outputable+import GHC.Types.SrcLoc+import GHC.Types.Var+import qualified GHC.Data.Strict as Strict++import Clash.GHCi.UI.Exception++-- | Info about a module. This information is generated every time a+-- module is loaded.+data ModInfo = ModInfo+ { modinfoSummary :: !ModSummary+ -- ^ Summary generated by GHC. Can be used to access more+ -- information about the module.+ , modinfoSpans :: [SpanInfo]+ -- ^ Generated set of information about all spans in the+ -- module that correspond to some kind of identifier for+ -- which there will be type info and/or location info.+ , modinfoRdrEnv :: !IfGlobalRdrEnv+ -- ^ What's in scope in the module.+ , modinfoLastUpdate :: !UTCTime+ -- ^ The timestamp of the file used to generate this record.+ }++-- | Type of some span of source code. Most of these fields are+-- unboxed but Haddock doesn't show that.+data SpanInfo = SpanInfo+ { spaninfoSrcSpan :: {-# UNPACK #-} !RealSrcSpan+ -- ^ The span we associate information with+ , spaninfoType :: !(Maybe Type)+ -- ^ The 'Type' associated with the span+ , spaninfoVar :: !(Maybe Id)+ -- ^ The actual 'Var' associated with the span, if+ -- any. This can be useful for accessing a variety of+ -- information about the identifier such as module,+ -- locality, definition location, etc.+ }++instance Outputable SpanInfo where+ ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i++-- | Test whether second span is contained in (or equal to) first span.+-- This is basically 'containsSpan' for 'SpanInfo'+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool+containsSpanInfo = containsSpan `on` spaninfoSrcSpan++-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'++-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'+-- respectively)+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo+spanInfoFromRealSrcSpan spn mty mvar =+ SpanInfo spn mty mvar++-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs+-- only a 'RealSrcSpan'+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing++-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'+srcSpanFilePath :: RealSrcSpan -> FilePath+srcSpanFilePath = unpackFS . srcSpanFile++-- | Try to find the location of the given identifier at the given+-- position in the module.+findLoc :: GhcMonad m+ => Map Module ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT GhciModuleError m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+ name <- maybeToExceptT GhciNoModuleNameGuess $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT GhciNoModuleInfoForCurrentFile $+ MaybeT $ pure $ M.lookup name infos++ name' <- findName infos span0 info string++ case getSrcSpan name' of+ UnhelpfulSpan{} -> throwE $ GhciNoLocationInfoForModule+ (maybe (ModuleName "<unknown>") moduleName (nameModule_maybe name'))+ span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map Module ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT GhciModuleError m [SrcSpan]+findNameUses infos span0 string =+ locToSpans <$> findLoc infos span0 string+ where+ locToSpans (modinfo,name',span') =+ stripSurrounding (span' : map toSrcSpan spans)+ where+ toSrcSpan s = RealSrcSpan (spaninfoSrcSpan s) Strict.Nothing+ spans = filter ((== Just name') . fmap getName . spaninfoVar)+ (modinfoSpans modinfo)++-- | Filter out redundant spans which surround/contain other spans.+stripSurrounding :: [SrcSpan] -> [SrcSpan]+stripSurrounding xs = filter (not . isRedundant) xs+ where+ isRedundant x = any (x `strictlyContains`) xs++ (RealSrcSpan s1 _) `strictlyContains` (RealSrcSpan s2 _)+ = s1 /= s2 && s1 `containsSpan` s2+ _ `strictlyContains` _ = False++-- | Try to resolve the name located at the given position, or+-- otherwise resolve based on the current module's scope.+findName :: GhcMonad m+ => Map Module ModInfo+ -> RealSrcSpan+ -> ModInfo+ -> String+ -> ExceptT GhciModuleError m Name+findName infos span0 mi string =+ case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> tryExternalModuleResolution+ Just name ->+ case getSrcSpan name of+ UnhelpfulSpan {} -> tryExternalModuleResolution+ RealSrcSpan {} -> return (getName name)+ where+ rdrs = modInfo_rdrs mi+ tryExternalModuleResolution =+ case find (matchName $ mkFastString string) rdrs of+ Nothing -> throwE GhciNoResolvedModules+ Just imported -> resolveNameFromModule infos imported++ matchName :: FastString -> Name -> Bool+ matchName str name =+ str ==+ occNameFS (getOccName name)++-- | Try to resolve the name from another (loaded) module's exports.+resolveNameFromModule :: GhcMonad m+ => Map Module ModInfo+ -> Name+ -> ExceptT GhciModuleError m Name+resolveNameFromModule infos name = do+ info <- maybe (throwE $ GhciNoModuleForName name) pure (nameModule_maybe name >>= \modL -> M.lookup modL infos)+ let all_names = modInfo_rdrs info+ maybe (throwE GhciNoMatchingModuleExport) pure $+ find (matchName name) all_names+ where+ matchName :: Name -> Name -> Bool+ matchName x y = occNameFS (getOccName x) ==+ occNameFS (getOccName y)++-- | Try to resolve the type display from the given span.+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $+ reverse spans' `spaninfosWithin` si++-- | Try to find the type of the given span.+findType :: GhcMonad m+ => Map Module ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT GhciModuleError m (ModInfo, Type)+findType infos span0 string = do+ name <- maybeToExceptT GhciNoModuleNameGuess $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT GhciNoModuleInfoForCurrentFile $+ MaybeT $ pure $ M.lookup name infos++ case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of+ Nothing -> (,) info <$> lift (exprType TM_Inst string)+ Just ty -> return (info, ty)+ where+ -- | Try to resolve the type display from the given span.+ resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type+ resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $+ reverse spans' `spaninfosWithin` si++-- | Guess a module name from a file path.+guessModule :: GhcMonad m+ => Map Module ModInfo -> FilePath -> MaybeT m Module+guessModule infos fp = do+ target <- lift $ guessTargetId fp+ case target of+ TargetModule mn -> MaybeT $ pure $ findModByModuleName mn+ TargetFile fp' _ -> guessModule' fp'+ where+ guessModule' :: GhcMonad m => FilePath -> MaybeT m Module+ guessModule' fp' = case findModByFp fp' of+ Just mn -> return mn+ Nothing -> do+ fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++ target' <- lift $ guessTargetId fp''+ case target' of+ TargetModule mn -> MaybeT . pure $ findModByModuleName mn+ _ -> MaybeT . pure $ findModByFp fp''++ findModByFp :: FilePath -> Maybe Module+ findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+ where+ mifp :: (Module, ModInfo) -> Maybe FilePath+ mifp = ml_hs_file . ms_location . modinfoSummary . snd++ findModByModuleName :: ModuleName -> Maybe Module+ findModByModuleName mn = find ((== mn) . moduleName) (M.keys infos)++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map Module ModInfo -> [Module]+ -> m (Map Module ModInfo)+collectInfo ms loaded = do+ df <- getDynFlags+ unit_state <- hsc_units <$> getSession+ liftIO (filterM cacheInvalid loaded) >>= \case+ [] -> return ms+ invalidated -> do+ liftIO (putStrLn ("Collecting type info for " +++ show (length invalidated) +++ " module(s) ... "))++ foldM (go df unit_state) ms invalidated+ where+ go df unit_state m name = do { info <- getModInfo name; return (M.insert name info m) }+ `MC.catch`+ (\(e :: SomeException) -> do+ liftIO $ putStrLn+ $ showSDocForUser df unit_state alwaysQualify+ $ "Error while getting type info from" <+>+ ppr name <> ":" <+> text (show e)+ return m)++ cacheInvalid name = case M.lookup name ms of+ Nothing -> return True+ Just mi -> do+ let fp = srcFilePath (modinfoSummary mi)+ last' = modinfoLastUpdate mi+ current <- getModificationTime fp+ exists <- doesFileExist fp+ if exists+ then return $ current /= last'+ else return True++-- | Get the source file path from a ModSummary.+-- If the .hs file is missing, and the .o file exists,+-- we return the .o file path.+srcFilePath :: ModSummary -> FilePath+srcFilePath modSum = fromMaybe obj_fp src_fp+ where+ src_fp = ml_hs_file ms_loc+ obj_fp = ml_obj_file ms_loc+ ms_loc = ms_location modSum++-- | Get info about the module: summary, types, etc.+getModInfo :: (GhcMonad m) => Module -> m ModInfo+getModInfo m = do+ mod_summary <- getModSummary m+ p <- parseModule mod_summary+ typechecked <- typecheckModule p+ let allTypes = processAllTypeCheckedModule typechecked+ let !rdr_env = tcg_rdr_env (fst $ tm_internals_ typechecked)+ ts <- liftIO $ getModificationTime $ srcFilePath mod_summary+ return $+ ModInfo+ { modinfoSummary = mod_summary+ , modinfoSpans = allTypes+ , modinfoRdrEnv = forceGlobalRdrEnv rdr_env+ , modinfoLastUpdate = ts+ }++-- | Get the 'Name's from the 'GlobalRdrEnv' of the 'ModInfo', if any.+modInfo_rdrs :: ModInfo -> [Name]+modInfo_rdrs mi = map greName $ globalRdrEnvElts $ modinfoRdrEnv mi++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: TypecheckedModule -> [SpanInfo]+processAllTypeCheckedModule tcm+ = mapMaybe toSpanInfo+ $ sortBy cmpSpan+ $ catMaybes (bts ++ ets ++ pts)+ where+ bts = map getTypeLHsBind $ listifyAllSpans tcs+ ets = map getTypeLHsExpr $ listifyAllSpans tcs+ pts = map getTypeLPat $ listifyAllSpans tcs++ tcs = tm_typechecked_source tcm++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's+ getTypeLHsBind :: LHsBind GhcTc -> Maybe (Maybe Id,SrcSpan,Type)+ getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _})+ = Just (Just (unLoc pid), getLocA pid,varType (unLoc pid))+ getTypeLHsBind _ = Nothing++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+ getTypeLHsExpr :: LHsExpr GhcTc -> Maybe (Maybe Id,SrcSpan,Type)+ getTypeLHsExpr e = Just (mid, getLocA e, lhsExprType e)+ where+ mid :: Maybe Id+ mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i+ | otherwise = Nothing++ unwrapVar (XExpr (WrapExpr _ var)) = var+ unwrapVar e' = e'++ -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's+ getTypeLPat :: LPat GhcTc -> Maybe (Maybe Id,SrcSpan,Type)+ getTypeLPat (L spn pat) = Just (getMaybeId pat,locA spn,hsPatType pat)+ where+ getMaybeId :: Pat GhcTc -> Maybe Id+ getMaybeId (VarPat _ (L _ vid)) = Just vid+ getMaybeId _ = Nothing++ -- | Get ALL source spans in the source.+ listifyAllSpans :: Typeable a => TypecheckedSource -> [LocatedA a]+ listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+ where+ p (L spn _) = isGoodSrcSpan (locA spn)++ -- | Variant of @syb@'s @everything@ (which summarises all nodes+ -- in top-down, left-to-right order) with a stop-condition on 'NameSet's+ -- and 'OverLitTc'+ everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+ everythingAllSpans k z f x+ | (False `mkQ` (const True :: NameSet -> Bool)) x = z+ -- Exception for OverLitTc: we have SrcSpans in the ol_witness field,+ -- but it's there only for HIE file info (see Note [Source locations for implicit function calls]).+ -- T16804 fails without this.+ | (False `mkQ` (const True :: OverLitTc -> Bool)) x = z+ | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)++ cmpSpan (_,a,_) (_,b,_)+ | a `isSubspanOf` b = LT+ | b `isSubspanOf` a = GT+ | otherwise = EQ++ -- | Pretty print the types into a 'SpanInfo'.+ toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo+ toSpanInfo (n,RealSrcSpan spn _,typ)+ = Just $ spanInfoFromRealSrcSpan spn (Just typ) n+ toSpanInfo _ = Nothing++-- helper stolen from @syb@ package+type GenericQ r = forall a. Data a => a -> r++mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = maybe r br (cast a)
+ src-bin-9.14/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,547 @@+{-# LANGUAGE FlexibleInstances, DeriveFunctor, DerivingVia, CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI.Monad (+ GHCi(..), startGHCi,+ GHCiState(..), GhciMonad(..),+ GHCiOption(..), isOptionSet, setOption, unsetOption,+ Command(..), CommandResult(..), cmdSuccess,+ CmdExecOutcome(..),+ LocalConfigBehaviour(..),+ PromptFunction,+ BreakLocation(..),+ TickArray,+ extractDynFlags, getDynFlags,++ runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,+ ActionStats(..), runAndPrintStats, runWithStats, printStats,++ prettyLocations,++ compileGHCiExpr,+ initInterpBuffering,+ turnOffBuffering, turnOffBuffering_,+ flushInterpBuffers,+ runInternal,+ mkEvalWrapper+ ) where++import Clash.GHCi.UI.Info (ModInfo)+import qualified GHC+import GHC.Driver.Monad hiding (liftIO)+import GHC.Utils.Outputable+import qualified GHC.Driver.Ppr as Ppr+import GHC.Types.Name.Occurrence+import GHC.Driver.Session+import GHC.Data.FastString+import GHC.Driver.Env+import GHC.Types.SrcLoc+import GHC.Types.SafeHaskell+import GHC.Driver.Make (ModIfaceCache(..))+import GHC.Unit+import GHC.Types.Name.Reader as RdrName (mkOrig)+import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)+import GHC.Runtime.Interpreter+import GHC.Runtime.Context+import GHCi.RemoteTypes+import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import GHC.Hs.Utils+import GHC.Utils.Misc+import GHC.Utils.Logger+import GHC.Runtime.Debugger.Breakpoints++import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)+import Numeric+import Data.IORef+import Data.Time+import System.Environment+import System.IO+import Control.Monad+import Prelude hiding ((<>))++import System.Console.Haskeline (CompletionFunc, InputT)+import Control.Monad.Catch as MC+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+import qualified Data.IntMap.Strict as IntMap+import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.LanguageExtensions as LangExt++import Clash.GHCi.UI.Print++-----------------------------------------------------------------------------+-- GHCi monad++data GHCiState = GHCiState+ {+ progname :: String,+ args :: [String],+ evalWrapper :: ForeignHValue, -- ^ of type @IO a -> IO a@+ prompt :: PromptFunction,+ prompt_cont :: PromptFunction,+ editor :: String,+ stop :: String,+ localConfig :: LocalConfigBehaviour,+ options :: [GHCiOption],+ line_number :: !Int, -- ^ input line+ break_ctr :: !Int,+ breaks :: !(IntMap.IntMap BreakLocation),+ tickarrays :: ModuleEnv TickArray,+ -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,+ -- so that we don't rebuild it each time the user sets+ -- a breakpoint.++ internalBreaks :: BreakpointOccurrences,+ -- ^ Keep a mapping from the source-level 'BreakpointId' to the+ -- occurrences of that breakpoint across modules.+ -- When we want to stop at a source 'BreakpointId', we essentially+ -- trigger a breakpoint for all 'InternalBreakpointId's matching+ -- the same source-id.++ ghci_commands :: [Command],+ -- ^ available ghci commands+ ghci_macros :: [Command],+ -- ^ user-defined macros+ last_command :: Maybe Command,+ -- ^ @:@ at the GHCi prompt repeats the last command, so we+ -- remember it here+ cmd_wrapper :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),+ -- ^ The command wrapper is run for each command or statement.+ -- The 'Bool' value denotes whether the command is successful and+ -- 'Nothing' means to exit GHCi.+ cmdqueue :: [String],++ remembered_ctx :: [InteractiveImport],+ -- ^ The imports that the user has asked for, via import+ -- declarations and :module commands. This list is+ -- persistent over :reloads (but any imports for modules+ -- that are not loaded are temporarily ignored). After a+ -- :load, all the home-package imports are stripped from+ -- this list.+ --+ -- See bugs #2049, #1873, #1360++ transient_ctx :: [InteractiveImport],+ -- ^ An import added automatically after a :load, usually of+ -- the most recently compiled module. May be empty if+ -- there are no modules loaded. This list is replaced by+ -- :load, :reload, and :add. In between it may be modified+ -- by :module.++ extra_imports :: [ImportDecl GhcPs],+ -- ^ These are "always-on" imports, added to the+ -- context regardless of what other imports we have.+ -- This is useful for adding imports that are required+ -- by setGHCiMonad. Be careful adding things here:+ -- you can create ambiguities if these imports overlap+ -- with other things in scope.+ --+ -- NB. although this is not currently used by GHCi itself,+ -- it was added to support other front-ends that are based+ -- on the GHCi code. Potentially we could also expose+ -- this functionality via GHCi commands.++ prelude_imports :: [ImportDecl GhcPs],+ -- ^ These imports are added to the context when+ -- -XImplicitPrelude is on and we don't have a *-module+ -- in the context. They can also be overridden by another+ -- import for the same module, e.g.+ -- "import Prelude hiding (map)"++ ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)],++ mod_infos :: !(Map Module ModInfo),++ flushStdHandles :: ForeignHValue,+ -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+ noBuffering :: ForeignHValue,+ -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+ ifaceCache :: ModIfaceCache+ }++-- | A GHCi command+data Command+ = Command+ { cmdName :: String+ -- ^ Name of GHCi command (e.g. "exit")+ , cmdAction :: String -> InputT GHCi CmdExecOutcome+ -- ^ The 'CmdExecOutcome' value denotes whether to exit GHCi cleanly or error out+ , cmdHidden :: Bool+ -- ^ Commands which are excluded from default completion+ -- and @:help@ summary. This is usually set for commands not+ -- useful for interactive use but rather for IDEs.+ , cmdCompletionFunc :: CompletionFunc GHCi+ -- ^ 'CompletionFunc' for arguments+ }++-- | Used to denote GHCi command execution result. Specifically, used to+-- distinguish between two ghci execution modes - "REPL" and "Expression+-- evaluation mode (ghc -e)". When in "REPL" mode, we don't want to exit+-- GHCi session when error occurs, (which is when we use "CmdSuccess").+-- Otherwise, when in expression evaluation mode, all command failures+-- should lead to GHCi session termination (with ExitFailure 1) which is+-- when "CmdFailure" is used(this is useful when executing scripts).+-- "CleanExit" is used to signal end of GHCi session (for example, when+-- ":quit" command is called).+data CmdExecOutcome+ = CleanExit+ | CmdSuccess+ | CmdFailure++data CommandResult+ = CommandComplete+ { cmdInput :: String+ , cmdResult :: Either SomeException (Maybe Bool)+ , cmdStats :: ActionStats+ }+ | CommandIncomplete+ -- ^ Unterminated multiline command+ deriving Show++cmdSuccess :: MonadThrow m => CommandResult -> m (Maybe Bool)+cmdSuccess CommandComplete{ cmdResult = Left e } =+ {- Don't add a backtrace from ghci/ghc to the exception from the user program! -}+#if MIN_VERSION_base(4,21,0)+ throwM (NoBacktrace e)+#else+ -- NoBacktrace is not available in older compilers+ throwM e+#endif+cmdSuccess CommandComplete{ cmdResult = Right r } = return r+cmdSuccess CommandIncomplete = return $ Just True++type PromptFunction = [String]+ -> Int+ -> GHCi SDoc++data GHCiOption+ = ShowTiming -- show time/allocs after evaluation+ | ShowType -- show the type of expressions+ | RevertCAFs -- revert CAFs after every evaluation+ | Multiline -- use multiline commands+ | CollectInfo -- collect and cache information about+ -- modules after load+ deriving Eq++-- | Treatment of ./.ghci files. For now we either load or+-- ignore. But later we could implement a "safe mode" where+-- only safe operations are performed.+--+data LocalConfigBehaviour+ = SourceLocalConfig+ | IgnoreLocalConfig+ deriving (Eq)++data BreakLocation+ = BreakLocation+ { breakLoc :: !SrcSpan+ , breakId :: !GHC.BreakpointId+ -- ^ The 'BreakpointId' uniquely identifies a source-level breakpoint+ , breakEnabled:: !Bool+ , onBreakCmd :: String+ }++instance Eq BreakLocation where+ loc1 == loc2 = breakId loc1 == breakId loc2++prettyLocations :: IntMap.IntMap BreakLocation -> SDoc+prettyLocations locs =+ case IntMap.null locs of+ True -> text "No active breakpoints."+ False -> vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ IntMap.toAscList locs++instance Outputable BreakLocation where+ ppr loc = (ppr $ GHC.bi_tick_mod $ breakId loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>+ if null (onBreakCmd loc)+ then empty+ else doubleQuotes (text (onBreakCmd loc))+ where pprEnaDisa = case breakEnabled loc of+ True -> text "enabled"+ False -> text "disabled"++recordBreak+ :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)+recordBreak brkLoc = do+ st <- getGHCiState+ let oldmap = breaks st+ oldActiveBreaks = IntMap.assocs oldmap+ -- don't store the same break point twice+ case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of+ (nm:_) -> return (True, nm)+ [] -> do+ let oldCounter = break_ctr st+ newCounter = oldCounter + 1+ setGHCiState $ st { break_ctr = newCounter,+ breaks = IntMap.insert oldCounter brkLoc oldmap+ }+ return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }+ deriving (Functor)+ deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT (IORef GHCiState) Ghc)++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Applicative GHCi where+ pure a = GHCi $ \_ -> pure a+ (<*>) = ap++instance Monad GHCi where+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s++class GhcMonad m => GhciMonad m where+ getGHCiState :: m GHCiState+ setGHCiState :: GHCiState -> m ()+ modifyGHCiState :: (GHCiState -> GHCiState) -> m ()+ reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> m a++instance GhciMonad GHCi where+ getGHCiState = GHCi $ \r -> liftIO $ readIORef r+ setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s+ modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef' r f+ reifyGHCi f = GHCi $ \r -> reifyGhc $ \s -> f (s, r)++instance GhciMonad (InputT GHCi) where+ getGHCiState = lift getGHCiState+ setGHCiState = lift . setGHCiState+ modifyGHCiState = lift . modifyGHCiState+ reifyGHCi = lift . reifyGHCi++liftGhc :: Ghc a -> GHCi a+liftGhc m = GHCi $ \_ -> m++instance MonadIO GHCi where+ liftIO = liftGhc . liftIO++instance HasDynFlags GHCi where+ getDynFlags = getSessionDynFlags++instance HasLogger GHCi where+ getLogger = hsc_logger <$> getSession++instance GhcMonad GHCi where+ setSession s' = liftGhc $ setSession s'+ getSession = liftGhc $ getSession+++instance HasDynFlags (InputT GHCi) where+ getDynFlags = lift getDynFlags++instance HasLogger (InputT GHCi) where+ getLogger = lift getLogger++instance GhcMonad (InputT GHCi) where+ setSession = lift . setSession+ getSession = lift getSession++isOptionSet :: GhciMonad m => GHCiOption -> m Bool+isOptionSet opt+ = do st <- getGHCiState+ return $! (opt `elem` options st)++setOption :: GhciMonad m => GHCiOption -> m ()+setOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GhciMonad m => GHCiOption -> m ()+unsetOption opt+ = do st <- getGHCiState+ setGHCiState (st{ options = filter (/= opt) (options st) })+++-- | Run a single Haskell expression+runStmt+ :: GhciMonad m+ => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)+runStmt stmt stmt_text step = do+ st <- getGHCiState+ GHC.handleSourceError (\e -> do printGhciException e; return Nothing) $ do+ let opts = GHC.execOptions+ { GHC.execSourceFile = progname st+ , GHC.execLineNumber = line_number st+ , GHC.execSingleStep = step+ , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))+ (EvalThis fhv) }+ Just <$> GHC.execStmt' stmt stmt_text opts++runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])+runDecls decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.handleSourceError (\e -> do printGhciException e+ return Nothing) $ do+ r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls+ return (Just r)++runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])+runDecls' decls = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $+ GHC.handleSourceError+ (\e -> do printGhciException e+ return Nothing)+ (Just <$> GHC.runParsedDecls decls)++resume :: GhciMonad m => GHC.SingleStep -> Maybe Int -> m GHC.ExecResult+resume step mbIgnoreCnt = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec step mbIgnoreCnt++-- --------------------------------------------------------------------------+-- timing & statistics++data ActionStats = ActionStats+ { actionAllocs :: Maybe Integer+ , actionElapsedTime :: Double+ } deriving Show++runAndPrintStats+ :: GhciMonad m+ => (a -> Maybe Integer)+ -> m a+ -> m (ActionStats, Either SomeException a)+runAndPrintStats getAllocs action = do+ result <- runWithStats getAllocs action+ case result of+ (stats, Right{}) -> do+ showTiming <- isOptionSet ShowTiming+ when showTiming $ do+ dflags <- getDynFlags+ liftIO $ printStats dflags stats+ _ -> return ()+ return result++runWithStats+ :: ExceptionMonad m+ => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)+runWithStats getAllocs action = do+ t0 <- liftIO getCurrentTime+ result <- MC.try action+ let allocs = either (const Nothing) getAllocs result+ t1 <- liftIO getCurrentTime+ let elapsedTime = realToFrac $ t1 `diffUTCTime` t0+ return (ActionStats allocs elapsedTime, result)++printStats :: DynFlags -> ActionStats -> IO ()+printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}+ = do let secs_str = showFFloat (Just 2) secs+ putStrLn (Ppr.showSDoc dflags (+ parens (text (secs_str "") <+> text "secs" <> comma <+>+ case mallocs of+ Nothing -> empty+ Just allocs ->+ text (separateThousands allocs) <+> text "bytes")))+ where+ separateThousands n = reverse . separate . reverse . show $ n+ where separate n'+ | n' `lengthAtMost` 3 = n'+ | otherwise = take 3 n' ++ "," ++ separate (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GhciMonad m => m ()+revertCAFs = do+ interp <- hscInterp <$> GHC.getSession+ liftIO $ interpCmd interp RtsRevertCAFs+ s <- getGHCiState+ when (not (ghc_e s)) turnOffBuffering+ -- Have to turn off buffering again, because we just+ -- reverted stdout, stderr & stdin to their defaults.+++-----------------------------------------------------------------------------+-- To flush buffers for the *interpreted* computation we need+-- to refer to *its* stdout/stderr handles++-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)+initInterpBuffering = do+ let mkHelperExpr :: OccName -> Ghc ForeignHValue+ mkHelperExpr occ =+ GHC.compileParsedExprRemote+ $ GHC.nlHsVar $ RdrName.mkOrig gHC_INTERNAL_GHCI_HELPERS occ+ nobuf <- mkHelperExpr $ mkVarOccFS (fsLit "disableBuffering")+ flush <- mkHelperExpr $ mkVarOccFS (fsLit "flushAll")+ return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GhciMonad m => m ()+flushInterpBuffers = do+ st <- getGHCiState+ interp <- hscInterp <$> GHC.getSession+ liftIO $ evalIO interp (flushStdHandles st)++-- | Turn off buffering for stdin, stdout, and stderr in the interpreter+turnOffBuffering :: GhciMonad m => m ()+turnOffBuffering = do+ st <- getGHCiState+ turnOffBuffering_ (noBuffering st)++turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()+turnOffBuffering_ fhv = do+ interp <- hscInterp <$> getSession+ liftIO $ evalIO interp fhv++mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue+mkEvalWrapper progname' args' =+ runInternal $ GHC.compileParsedExprRemote+ $ evalWrapper' `GHC.mkHsApp` nlHsString progname'+ `GHC.mkHsApp` nlList (map nlHsString args')+ where+ nlHsString = nlHsLit . mkHsString+ evalWrapper' =+ GHC.nlHsVar $ RdrName.mkOrig gHC_INTERNAL_GHCI_HELPERS (mkVarOccFS (fsLit "evalWrapper"))++-- | Run a 'GhcMonad' action to compile an expression for internal usage.+runInternal :: GhcMonad m => m a -> m a+runInternal =+ withTempSession mkTempSession+ where+ mkTempSession = hscUpdateFlags (\dflags -> dflags+ { -- Running GHCi's internal expression is incompatible with -XSafe.+ -- We temporarily disable any Safe Haskell settings while running+ -- GHCi internal expressions. (see #12509)+ safeHaskell = Sf_None,+ -- Disable dumping of any data during evaluation of GHCi's internal+ -- expressions. (#17500)+ dumpFlags = EnumSet.empty+ }+ -- RebindableSyntax can wreak havoc with GHCi in several ways+ -- (see #13385 and #14342 for examples), so we temporarily+ -- disable it too.+ `xopt_unset` LangExt.RebindableSyntax+ -- We heavily depend on -fimplicit-import-qualified to compile expr+ -- with fully qualified names without imports.+ `gopt_set` Opt_ImplicitImportQualified+ )++compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue+compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
+ src-bin-9.14/Clash/GHCi/UI/Print.hs view
@@ -0,0 +1,92 @@+module Clash.GHCi.UI.Print+ ( printForUserNeverQualify+ , printForUserGlobalRdrEnv+ , printForUser+ , printForUserPartWay+ , printError+ , printGhciException+ , printGhciCommandException+ ) where++import qualified GHC+import GHC.Types.Name.Reader+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.Error+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Errors+import GHC.Driver.Config.Diagnostic++import GHC.Utils.Logger+import GHC.Utils.Error+import GHC.Utils.Outputable+import qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx)+import qualified GHC.Driver.Ppr as Ppr++import Prelude hiding ((<>))+import System.IO++import Clash.GHCi.UI.Exception+++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- GHC.getInteractiveDynFlags+ liftIO $ Ppr.printForUser dflags stdout neverQualify AllTheWay doc++printForUserGlobalRdrEnv :: (GhcMonad m, Outputable info)+ => Maybe (GlobalRdrEnvX info) -> SDoc -> m ()+printForUserGlobalRdrEnv mb_rdr_env doc = do+ dflags <- GHC.getInteractiveDynFlags+ name_ppr_ctx <- mkNamePprCtxFromGlobalRdrEnv dflags mb_rdr_env+ liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx AllTheWay doc+ where+ mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx+ mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =+ withSession $ \ hsc_env ->+ let unit_env = hsc_unit_env hsc_env+ ptc = initPromotionTickContext dflags+ in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+ name_ppr_ctx <- GHC.getNamePprCtx+ dflags <- GHC.getInteractiveDynFlags+ liftIO $ Ppr.printForUserColoured dflags stdout name_ppr_ctx AllTheWay doc++printForUserPartWay :: GhcMonad m => SDoc -> m ()+printForUserPartWay doc = do+ name_ppr_ctx <- GHC.getNamePprCtx+ dflags <- GHC.getInteractiveDynFlags+ liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx DefaultDepth doc++-- | pretty-print a 'GhciCommandMessage'+printError :: GhcMonad m => GhciCommandMessage -> m ()+printError err =+ let errEnvelope = mkPlainErrorMsgEnvelope interactiveSrcSpan err+ in printError' (const NoDiagnosticOpts) (singleMessage errEnvelope)++-- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting+-- for some error messages.+printGhciException :: GhcMonad m => SourceError -> m ()+printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err))++printGhciCommandException :: GhcMonad m => GhciCommandError -> m ()+printGhciCommandException (GhciCommandError errs) = printError' initGhciPrintConfig errs++printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m ()+printError' get_config err = do+ dflags <- getDynFlags+ logger <- getLogger+ let !diag_opts = initDiagOpts dflags+ !print_config = get_config dflags+ liftIO $ printMessages logger print_config diag_opts err++-- | Initialize the 'GhciMessageOpts' with the 'GhcOpts' from the 'DynFlags'+initGhciPrintConfig :: DynFlags -> GhciMessageOpts+initGhciPrintConfig dflags = GhciMessageOpts+ { ghcMessageOpts = initPrintConfig dflags+ , ghciCommandMessageOpts = NoDiagnosticOpts+ }
+ src-bin-9.14/Clash/GHCi/Util.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}++-- | Utilities for GHCi.+module Clash.GHCi.Util where++-- NOTE: Avoid importing GHC modules here, because the primary purpose+-- of this module is to not use UnboxedTuples in a module that imports+-- lots of other modules. See issue#13101 for more info.++import GHC.Exts+import GHC.Types++anyToPtr :: a -> IO (Ptr ())+anyToPtr x =+ IO (\s -> case anyToAddr# x s of+ (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
+ src-bin-9.14/Clash/Main.hs view
@@ -0,0 +1,595 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Clash.Main (defaultMain, defaultMainWithAction) where++-- The official GHC API+import qualified GHC+import GHC (parseTargetFiles, Ghc, GhcMonad(..),+ LoadHowMuch(..) )++import GHC.Driver.Backend hiding (Backend)+import GHC.Driver.CmdLine+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Phases+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Pipeline ( oneShot )+import GHC.Driver.MakeFile ( doMkDependHS )+import GHC.Driver.Backpack ( doBackpack )+import GHC.Driver.Plugins+import GHC.Driver.Config.Logger (initLogFlags)+import GHC.Driver.Config.Diagnostic++import GHC.Platform+import GHC.Platform.Host++#if defined(HAVE_INTERNAL_INTERPRETER)+import Clash.GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++import GHC.Runtime.Loader ( loadFrontendPlugin, initializeSessionPlugins )++import GHC.Unit.Module ( ModuleName, mkModuleName )+import GHC.Unit.Module.ModIface+import GHC.Unit.State ( pprUnits, pprUnitsSimple )+import GHC.Unit.Finder ( findImportedModule, FindResult(..) )+import GHC.Unit.Types ( IsBootInterface(..) )++import GHC.Types.Basic ( failed )+import GHC.Types.SrcLoc+import GHC.Types.SourceError+import GHC.Types.Unique.Supply+import GHC.Types.PkgQual++import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Monad ( liftIO )+import GHC.Utils.Binary ( openBinMem, put_ )+import GHC.Utils.Logger++import GHC.Settings.Config+import GHC.Settings.Constants+import GHC.Settings.IO++import GHC.HandleEncoding+import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.SysTools.BaseDir++import GHC.Iface.Load+import GHC.Iface.Recomp.Binary ( fingerprintBinMem )++import GHC.Tc.Utils.Monad ( initIfaceCheck )+import GHC.Iface.Errors.Ppr++import Clash.GHC.Driver.Session.Mode+import Clash.GHC.Driver.Session.Lint+import GHC.Driver.Session.Units++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except (throwE, runExceptT)+import Data.List (intercalate)+import Prelude+import qualified Data.List.NonEmpty as NE++-- clash additions+import Paths_clash_ghc+import Clash.GHCi.UI (makeHDL)+import Control.Monad.Catch (catch)+import Data.List (nub)+import Data.Proxy+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import qualified Data.Version (showVersion)+import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.Driver.Session as Session++import Clash.Backend (Backend)+import Clash.Backend.SystemVerilog (SystemVerilogState)+import Clash.Backend.VHDL (VHDLState)+import Clash.Backend.Verilog (VerilogState)+import Clash.Driver.Types+ (ClashOpts (..), defClashOpts)+import Clash.GHC.ClashFlags+import Clash.Util (clashLibVersion)+import Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions)+import Clash.GHC.Util (handleClashException)++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++defaultMain :: [String] -> IO ()+defaultMain = defaultMainWithAction (return ())++defaultMainWithAction :: Ghc () -> [String] -> IO ()+defaultMainWithAction startAction = flip withArgs $ do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ configureHandleEncoding+ GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+ -- 1. extract the -B flag from the args+ argv0 <- getArgs++ let argv1 = map (mkGeneralLocated "on the commandline") argv0+ libDir <- ghcLibDir++ r <- newIORef defClashOpts+ (argv2, clashFlagWarnings) <- parseClashFlags r argv1++ -- 2. Parse the "mode" flags (--make, --interactive etc.)+ (mode, units, argv3, modeFlagWarnings) <- parseModeFlags argv2+ let flagWarnings = modeFlagWarnings ++ clashFlagWarnings++ -- If all we want to do is something like showing the version number+ -- then do it now, before we start a GHC session etc. This makes+ -- getting basic information much more resilient.++ -- In particular, if we wait until later before giving the version+ -- number then bootstrapping gets confused, as it tries to find out+ -- what version of GHC it's using before package.conf exists, so+ -- starting the session fails.+ case mode of+ Left preStartupMode ->+ do case preStartupMode of+ ShowSupportedExtensions -> showSupportedExtensions (Just libDir)+ ShowVersion -> showVersion+ ShowNumVersion -> putStrLn cProjectVersion+ ShowOptions isInteractive -> showOptions isInteractive r+ Right postStartupMode ->+ GHC.runGhc (Just libDir) $ do++ dflags <- GHC.getSessionDynFlags+ let dflagsExtra = setWantedLanguageExtensions dflags+ ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+ ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+ ghcTyLitKNPlugin = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+ dflagsExtra1 =+ dflagsExtra+ { Session.pluginModNames =+ nub+ ( ghcTyLitNormPlugin+ : ghcTyLitExtrPlugin+ : ghcTyLitKNPlugin+ : Session.pluginModNames dflagsExtra+ )+ }++ case postStartupMode of+ Left preLoadMode ->+ liftIO $ do+ case preLoadMode of+ ShowInfo -> showInfo dflagsExtra1+ ShowGhcUsage -> showGhcUsage dflagsExtra1+ ShowGhciUsage -> showGhciUsage dflagsExtra1+ PrintWithDynFlags f -> putStrLn (f dflagsExtra1)+ Right postLoadMode ->+ main' postLoadMode units dflagsExtra1 argv3 flagWarnings startAction r++main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn]+ -> Ghc () -> IORef ClashOpts+ -> Ghc ()+main' postLoadMode units dflags0 args flagWarnings startAction clashOpts = do+ let args' = case postLoadMode of+ DoRun -> takeWhile (\arg -> unLoc arg /= "--") args+ _ -> args++ -- set the default GhcMode, backend and GhcLink. The backend+ -- can be further adjusted on a module by module basis, using only+ -- the -fllvm and -fasm flags. If the default backend is not+ -- LLVM or NCG, -fllvm and -fasm have no effect.+ let dflt_backend = backend dflags0+ (mode, bcknd, link)+ = case postLoadMode of+ DoInteractive -> (CompManager, interpreterBackend, LinkInMemory)+ DoEval _ -> (CompManager, interpreterBackend, LinkInMemory)+ DoRun -> (CompManager, interpreterBackend, LinkInMemory)+ DoMake -> (CompManager, dflt_backend, LinkBinary)+ DoBackpack -> (CompManager, dflt_backend, LinkBinary)+ DoMkDependHS -> (MkDepend, dflt_backend, LinkBinary)+ DoAbiHash -> (OneShot, dflt_backend, LinkBinary)+ DoVHDL -> (CompManager, noBackend, NoLink)+ DoVerilog -> (CompManager, noBackend, NoLink)+ DoSystemVerilog -> (CompManager, noBackend, NoLink)+ _ -> (OneShot, dflt_backend, LinkBinary)++ let dflags1 = dflags0{ ghcMode = mode,+ backend = bcknd,+ ghcLink = link,+ verbosity = case postLoadMode of+ DoEval _ -> 0+ DoRun -> 0+ _other -> 1+ }++ -- turn on -fimplicit-import-qualified for GHCi now, so that it+ -- can be overridden from the command-line+ -- XXX: this should really be in the interactive DynFlags, but+ -- we don't set that until later in interactiveUI+ -- We also set -fignore-optim-changes and -fignore-hpc-changes,+ -- which are program-level options. Again, this doesn't really+ -- feel like the right place to handle this, but we don't have+ -- a great story for the moment.+ dflags2 | DoInteractive <- postLoadMode = def_ghci_flags+ | DoEval _ <- postLoadMode = def_ghci_flags+ | DoRun <- postLoadMode = def_ghci_flags+ | otherwise = dflags1+ where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified+ `gopt_set` Opt_IgnoreOptimChanges+ `gopt_set` Opt_IgnoreHpcChanges+ -- Setting this by default has the nice effect that+ -- -fno-code and --interactive falls back to interpreter rather than+ -- object code but has little other effect unless you are also using+ -- fat interface files.+ `gopt_set` Opt_UseBytecodeRatherThanObjects+ -- By default enable the debugger by inserting breakpoints+ `gopt_set` Opt_InsertBreakpoints++ logger1 <- getLogger+ let logger2 = setLogFlags logger1 (initLogFlags dflags2)++ -- The rest of the arguments are "dynamic"+ -- Leftover ones are presumably files+ (dflags4, fileish_args, dynamicFlagWarnings) <-+ GHC.parseDynamicFlags logger2 dflags2 args'++ let logger4 = setLogFlags logger2 (initLogFlags dflags4)++ GHC.prettyPrintGhcErrors logger4 $ do++ let diag_opts = initDiagOpts dflags4+ let flagWarnings' = GhcDriverMessage <$> mconcat [warnsToMessages diag_opts flagWarnings, dynamicFlagWarnings]++ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ liftIO $ printOrThrowDiagnostics logger4 (initPrintConfig dflags4) diag_opts flagWarnings'++ liftIO $ showBanner postLoadMode dflags4++ let (dflags5, srcs, objs) = parseTargetFiles dflags4 (map unLoc fileish_args)++ -- we've finished manipulating the DynFlags, update the session+ _ <- GHC.setSessionDynFlags dflags5+ dflags6 <- GHC.getSessionDynFlags++ liftIO . modifyIORef' clashOpts $ \opts ->+ opts {opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags6)}++ -- Must do this before loading plugins+ liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)++ -- Initialise plugins here because the plugin author might already expect this+ -- subsequent call to `getLogger` to be affected by a plugin.+ initializeSessionPlugins+ hsc_env <- getSession+ logger <- getLogger+++ ---------------- Display configuration -----------+ case verbosity dflags6 of+ v | v == 4 -> liftIO $ dumpUnitsSimple hsc_env+ | v >= 5 -> liftIO $ dumpUnits hsc_env+ | otherwise -> return ()++ ---------------- Final sanity checking -----------+ liftIO $ checkOptions postLoadMode dflags6 srcs objs units++ ---------------- Do the business -----------+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ clashOpts' <- liftIO (readIORef clashOpts)+ let clash fun = catch (fun startAction clashOpts srcs) (handleClashException dflags6 clashOpts')+ case postLoadMode of+ ShowInterface f -> liftIO $ showIface logger+ (hsc_dflags hsc_env)+ (hsc_units hsc_env)+ (hsc_NC hsc_env)+ f+ DoMake -> doMake units srcs+ DoMkDependHS -> doMkDependHS (map fst srcs)+ StopBefore p -> liftIO (oneShot hsc_env p srcs)+ DoInteractive -> ghciUI clashOpts units srcs Nothing+ DoEval exprs -> ghciUI clashOpts units srcs $ Just $ reverse exprs+ DoRun -> doRun clashOpts units srcs args+ DoAbiHash -> abiHash (map fst srcs)+ ShowPackages -> liftIO $ showUnits hsc_env+ DoFrontend f -> doFrontend f srcs+ DoBackpack -> doBackpack (map fst srcs)+ DoVHDL -> clash makeVHDL+ DoVerilog -> clash makeVerilog+ DoSystemVerilog -> clash makeSystemVerilog++ liftIO $ dumpFinalStats logger++doRun :: IORef ClashOpts -> [String] -> [(FilePath, Maybe Phase)] -> [Located String] -> Ghc ()+doRun clashOpts units srcs args = do+ dflags <- getDynFlags+ let mainFun = fromMaybe "main" (mainFunIs dflags)+ ghciUI clashOpts units srcs (Just ["System.Environment.withArgs " ++ show args' ++ " (Control.Monad.void " ++ mainFun ++ ")"])+ where+ args' = drop 1 $ dropWhile (/= "--") $ map unLoc args++ghciUI :: IORef ClashOpts -> [String] -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()+#if !defined(HAVE_INTERNAL_INTERPRETER)+ghciUI _ _ _ _ =+ throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI clashOpts units srcs maybe_expr = do+ hs_srcs <- case NE.nonEmpty units of+ Just ne_units -> do+ initMulti ne_units (checkOptions DoMake)+ Nothing -> do+ case srcs of+ [] -> return []+ _ -> do+ s <- initMake srcs+ dflags <- getDynFlags+ return $ map (uncurry (,Just $ homeUnitId_ dflags,)) s+ interactiveUI (defaultGhciSettings clashOpts) hs_srcs maybe_expr+#endif++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [String] -> [(String, Maybe Phase)] -> Ghc ()+doMake units targets = do+ hs_srcs <- case NE.nonEmpty units of+ Just ne_units -> do+ initMulti ne_units (checkOptions DoMake)+ Nothing -> do+ s <- initMake targets+ return $ map (uncurry (,Nothing,)) s+ case hs_srcs of+ [] -> return ()+ _ -> do+ targets' <- mapM (\(src, uid, phase) -> GHC.guessTarget src uid phase) hs_srcs+ GHC.setTargets targets'+ ok_flag <- GHC.load LoadAllTargets+ when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: PostLoadMode -> DynFlags -> IO ()+showBanner _postLoadMode dflags = do+ let verb = verbosity dflags++#if defined(HAVE_INTERNAL_INTERPRETER)+ -- Show the GHCi banner+ when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++ -- Display details of the configuration in verbose mode+ when (verb >= 2) $+ do hPutStr stderr "Glasgow Haskell Compiler, Version "+ hPutStr stderr cProjectVersion+ hPutStr stderr ", stage "+ hPutStr stderr cStage+ hPutStr stderr " booted by GHC version "+ hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: DynFlags -> IO ()+showInfo dflags = do+ let sq x = " [" ++ x ++ "\n ]"+ putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags++-- TODO use GHC.Utils.Error once that is disentangled from all the other GhcMonad stuff?+showSupportedExtensions :: Maybe String -> IO ()+showSupportedExtensions m_top_dir = do+ res <- runExceptT $ do+ top_dir <- lift (tryFindTopDir m_top_dir) >>= \case+ Nothing -> throwE $ SettingsError_MissingData "Could not find the top directory, missing -B flag"+ Just dir -> pure dir+ initSettings top_dir+ arch_os <- case res of+ Right s -> pure $ platformArchOS $ sTargetPlatform s+ Left (SettingsError_MissingData msg) -> do+ hPutStrLn stderr $ "WARNING: " ++ show msg+ hPutStrLn stderr $ "cannot know target platform so guessing target == host (native compiler)."+ pure hostPlatformArchOS+ Left (SettingsError_BadData msg) -> do+ hPutStrLn stderr msg+ exitWith $ ExitFailure 1+ mapM_ putStrLn $ supportedLanguagesAndExtensions arch_os++showVersion :: IO ()+showVersion = putStrLn $ concat [ "Clash, version "+ , Data.Version.showVersion version+ , " (using clash-lib, version: "+ , Data.Version.showVersion clashLibVersion+ , ")"+ ]++showOptions :: Bool -> IORef ClashOpts -> IO ()+showOptions isInteractive = putStr . unlines . availableOptions+ where+ availableOptions opts = concat [+ flagsForCompletion isInteractive,+ map ('-':) (getFlagNames mode_flags),+ map ('-':) (getFlagNames (flagsClash opts))+ ]+ getFlagNames opts = map flagName opts++showGhcUsage :: DynFlags -> IO ()+showGhcUsage = showUsage False++showGhciUsage :: DynFlags -> IO ()+showGhciUsage = showUsage True++showUsage :: Bool -> DynFlags -> IO ()+showUsage ghci dflags = do+ let usage_path = if ghci then ghciUsagePath dflags+ else ghcUsagePath dflags+ usage <- readFile usage_path+ progName <- getProgName+ dump progName usage+ where+ dump progName xs = case xs of+ "" -> return ()+ '$':'$':s -> putStr progName >> dump progName s+ c:s -> putChar c >> dump progName s++dumpFinalStats :: Logger -> IO ()+dumpFinalStats logger = do+ when (logHasDumpFlag logger Opt_D_faststring_stats) $ dumpFastStringStats logger++ when (logHasDumpFlag logger Opt_D_dump_faststrings) $ do+ fss <- getFastStringTable+ let ppr_table = fmap ppr_segment (fss `zip` [0..])+ ppr_segment (s,n) = hang (text "Segment" <+> int n) 2 (vcat (fmap ppr_bucket (s `zip` [0..])))+ ppr_bucket (b,n) = hang (text "Bucket" <+> int n) 2 (vcat (fmap ftext b))+ putDumpFileMaybe logger Opt_D_dump_faststrings "FastStrings" FormatText (vcat ppr_table)++dumpFastStringStats :: Logger -> IO ()+dumpFastStringStats logger = do+ segments <- getFastStringTable+ hasZ <- getFastStringZEncCounter+ let buckets = concat segments+ bucketsPerSegment = map length segments+ entriesPerBucket = map length buckets+ entries = sum entriesPerBucket+ msg = text "FastString stats:" $$ nest 4 (vcat+ [ text "segments: " <+> int (length segments)+ , text "buckets: " <+> int (sum bucketsPerSegment)+ , text "entries: " <+> int entries+ , text "largest segment: " <+> int (maximum bucketsPerSegment)+ , text "smallest segment: " <+> int (minimum bucketsPerSegment)+ , text "longest bucket: " <+> int (maximum entriesPerBucket)+ , text "has z-encoding: " <+> (hasZ `pcntOf` entries)+ ])+ -- we usually get more "has z-encoding" than "z-encoded", because+ -- when we z-encode a string it might hash to the exact same string,+ -- which is not counted as "z-encoded". Only strings whose+ -- Z-encoding is different from the original string are counted in+ -- the "z-encoded" total.+ putMsg logger msg+ where+ x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'++showUnits, dumpUnits, dumpUnitsSimple :: HscEnv -> IO ()+showUnits hsc_env = putStrLn (showSDoc (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env)))+dumpUnits hsc_env = putMsg (hsc_logger hsc_env) (pprUnits (hsc_units hsc_env))+dumpUnitsSimple hsc_env = putMsg (hsc_logger hsc_env) (pprUnitsSimple (hsc_units hsc_env))++-- -----------------------------------------------------------------------------+-- Frontend plugin support++doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()+doFrontend modname srcs = do+ hsc_env <- getSession+ (frontend_plugin, _pkgs, _deps) <- liftIO $ loadFrontendPlugin hsc_env modname -- TODO do these need to recorded?+ frontend frontend_plugin+ (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs++-- -----------------------------------------------------------------------------+-- ABI hash support++{-+ ghc --abi-hash Data.Foo System.Bar++Generates a combined hash of the ABI for modules Data.Foo and+System.Bar. The modules must already be compiled, and appropriate -i+options may be necessary in order to find the .hi files.++This is used by Cabal for generating the ComponentId for a+package. The ComponentId must change when the visible ABI of+the package changes, so during registration Cabal calls ghc --abi-hash+to get a hash of the package's ABI.+-}++-- | Print ABI hash of input modules.+--+-- The resulting hash is the MD5 of the GHC version used (#5328,+-- see 'hiVersion') and of the existing ABI hash from each module (see+-- 'mi_mod_hash').+abiHash :: [String] -- ^ List of module names+ -> Ghc ()+abiHash strs = do+ hsc_env <- getSession+ let dflags = hsc_dflags hsc_env++ liftIO $ do++ let find_it str = do+ let modname = mkModuleName str+ r <- findImportedModule hsc_env modname NoPkgQual+ case r of+ Found _ m -> return m+ _error ->+ let opts = initIfaceMessageOpts dflags+ err_txt = missingInterfaceErrorDiagnostic opts+ $ cannotFindModule hsc_env modname r+ in throwGhcException . CmdLineError $ showSDoc dflags err_txt++ mods <- mapM find_it strs++ -- MP: loadUserInterface is inefficient here since we will never find a cached+ -- interface. computeInterface is probably better.+ let get_iface modl = loadUserInterface NotBoot (text "abiHash") modl+ ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods++ bh <- openBinMem (3*1024) -- just less than a block+ put_ bh hiVersion+ -- package hashes change when the compiler version changes (for now)+ -- see #5328+ mapM_ (put_ bh . mi_mod_hash) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showPpr dflags f)+++-----------------------------------------------------------------------------+-- HDL Generation++makeHDL'+ :: forall backend+ . Backend backend+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [(String, Maybe Phase)]+ -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' proxy startAction clashOpts srcs =+ makeHDL proxy startAction clashOpts (map fst srcs)++makeVHDL :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL = makeHDL' (Proxy @VHDLState)++makeVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Proxy @VerilogState)++makeSystemVerilog :: Ghc () -> IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Proxy @SystemVerilogState)
src-bin-9.6/Clash/GHCi/UI.hs view
@@ -2410,6 +2410,8 @@ -> [FilePath] -> m () makeHDL Proxy startAction optsRef srcs = do+ -- Validate every target before loading or synthesizing any of them.+ mapM_ (\src -> GHC.guessTarget src Nothing Nothing) srcs dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef
src-bin-9.8/Clash/GHCi/UI.hs view
@@ -2411,6 +2411,8 @@ -> [FilePath] -> m () makeHDL Proxy startAction optsRef srcs = do+ -- Validate every target before loading or synthesizing any of them.+ mapM_ (\src -> GHC.guessTarget src Nothing Nothing) srcs dflags <- GHC.getSessionDynFlags liftIO $ do startTime <- Clock.getCurrentTime opts0 <- readIORef optsRef
src-ghc/Clash/GHC/Evaluator.hs view
@@ -29,7 +29,10 @@ #endif import qualified Data.Primitive.ByteArray as BA import qualified Data.Text as Text+import Data.Text.Extra (showt)+import qualified GHC.Classes import GHC.Num.Integer (Integer (..))+import qualified GHC.Prim import Clash.Core.DataCon import Clash.Core.Evaluator.Types@@ -116,7 +119,7 @@ stepPrim :: PrimInfo -> Step stepPrim pInfo m tcm- | primName pInfo == "GHC.Prim.realWorld#" =+ | primName pInfo == showt 'GHC.Prim.realWorld# = ghcUnwind (PrimVal pInfo [] []) m tcm | otherwise =@@ -158,7 +161,7 @@ -- even when that 'x' is _|_. This makes the evaluation -- rule lazier than the actual Haskel implementations which -- are strict in the first argument and lazy in the second.- [a0, a1] | primName p `elem` ["GHC.Classes.&&","GHC.Classes.||"] ->+ [a0, a1] | primName p `elem` [showt '(GHC.Classes.&&), showt '(GHC.Classes.||)] -> let (m0,i) = newLetBinding tcm m a0 (m1,j) = newLetBinding tcm m0 a1 in ghcPrimStep tcm (forcePrims m) p [] [Suspend (Var i), Suspend (Var j)] m1
src-ghc/Clash/GHC/Evaluator/Primitive.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -585,8 +586,7 @@ in reduce . Literal . Int8Literal . toInteger $ I# b $(namePat 'GHC.Prim.int8ToInt#) | [i] <- int8Literals' args -> reduce . Literal $ IntLiteral i- -- XXX: Primitive does not exist?- "GHC.Prim.negateInt8" | [i] <- int8Literals' args+ $(namePat 'GHC.Prim.negateInt8#) | [i] <- int8Literals' args -> let !(I8# a) = fromInteger i in reduce (Literal (Int8Literal (toInteger (I8# (negateInt8# a))))) $(namePat 'GHC.Prim.plusInt8#) | Just r <- liftI8 plusInt8# args@@ -641,8 +641,7 @@ in reduce . Literal . Int16Literal . toInteger $ I# b $(namePat 'GHC.Prim.int16ToInt#) | [i] <- int16Literals' args -> reduce . Literal $ IntLiteral i- -- XXX: Primitive does not exist?- "GHC.Prim.negateInt16" | [i] <- int16Literals' args+ $(namePat 'GHC.Prim.negateInt16#) | [i] <- int16Literals' args -> let !(I16# a) = fromInteger i in reduce (Literal (Int16Literal (toInteger (I16# (negateInt16# a))))) $(namePat 'GHC.Prim.plusInt16#) | Just r <- liftI16 plusInt16# args@@ -697,8 +696,7 @@ in reduce . Literal . Int32Literal . toInteger $ I# b $(namePat 'GHC.Prim.int32ToInt#) | [i] <- int32Literals' args -> reduce . Literal $ IntLiteral i- -- XXX: Primitive does not exist?- "GHC.Prim.negateInt32" | [i] <- int32Literals' args+ $(namePat 'GHC.Prim.negateInt32#) | [i] <- int32Literals' args -> let !(I32# a) = fromInteger i in reduce (Literal (Int32Literal (toInteger (I32# (negateInt32# a))))) $(namePat 'GHC.Prim.plusInt32#) | Just r <- liftI32 plusInt32# args@@ -751,8 +749,7 @@ -> reduce (Literal (Int64Literal i)) $(namePat 'GHC.Prim.int64ToInt#) | [i] <- int64Literals' args -> reduce . Literal $ IntLiteral i- -- XXX: Primitive does not exist?- "GHC.Prim.negateInt64" | [i] <- int64Literals' args+ $(namePat 'GHC.Prim.negateInt64#) | [i] <- int64Literals' args -> let !(I64# a) = fromInteger i in reduce (Literal (Int64Literal (toInteger (I64# (negateInt64# a))))) $(namePat 'GHC.Prim.plusInt64#) | Just r <- liftI64 plusInt64# args@@ -1275,6 +1272,8 @@ in reduce (Literal (WordLiteral (toInteger (W# w)))) -- XXX: Primitive does not exist?+#if !MIN_VERSION_ghc(9,14,0)+ -- 'getSizeofMutBigNat#' was removed from GHC.Prim in GHC 9.14. "GHC.Prim.getSizeofMutBigNat#" | [PrimVal _mbaTy _ [baV] ,PrimVal rwTy _ _@@ -1288,6 +1287,7 @@ in reduce $ mkApps (Data tupDc) (map Right tyArgs ++ [Left (Prim rwTy) ,Left lit])+#endif $(namePat 'GHC.Prim.resizeMutableByteArray#) | [PrimVal mbaTy _ [baV]@@ -1923,27 +1923,19 @@ "GHC.Real.$wf1" -- :: Int# -> Int# -> Int# | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))- "GHC.Internal.Real.^_$s$spowImpl2" -- :: Int# -> Integer -> Integer- | [intLiteral -> Just j, integerLiteral -> Just i] <- args- -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))- "GHC.Internal.Real.^_$s$spowImpl" -- :: Int -> Integer -> Integer- | [intLiteral -> Just j, integerLiteral -> Just i] <- args- -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))- "GHC.Internal.Real.$w$spowImpl" -- :: Integer -> Int# -> Integer- | [integerLiteral -> Just i, intLiteral -> Just j] <- args- -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))- "GHC.Internal.Real.$w$spowImpl1" -- :: Int# -> Int# -> Integer- | [intLiteral -> Just i, intLiteral -> Just j] <- args- -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))- "GHC.Real.^_$s$spowImpl2" -- :: Int# -> Integer -> Integer- | [intLiteral -> Just j, integerLiteral -> Just i] <- args- -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))- "GHC.Real.$w$spowImpl" -- :: Integer -> Int# -> Integer- | [integerLiteral -> Just i, intLiteral -> Just j] <- args- -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))- "GHC.Real.$w$spowImpl1" -- :: Int# -> Int# -> Integer- | [intLiteral -> Just i, intLiteral -> Just j] <- args- -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))+ -- Which specialization each worker name implements shifts between GHC+ -- versions, so they all share one shape-dispatching implementation. See+ -- 'powImplWorker'.+ "GHC.Internal.Real.^_$s$spowImpl" | Just r <- powImplWorker args -> reduce r+ "GHC.Internal.Real.^_$s$spowImpl1" | Just r <- powImplWorker args -> reduce r+ "GHC.Internal.Real.^_$s$spowImpl2" | Just r <- powImplWorker args -> reduce r+ "GHC.Internal.Real.$w$spowImpl" | Just r <- powImplWorker args -> reduce r+ "GHC.Internal.Real.$w$spowImpl1" | Just r <- powImplWorker args -> reduce r+ "GHC.Real.^_$s$spowImpl" | Just r <- powImplWorker args -> reduce r+ "GHC.Real.^_$s$spowImpl1" | Just r <- powImplWorker args -> reduce r+ "GHC.Real.^_$s$spowImpl2" | Just r <- powImplWorker args -> reduce r+ "GHC.Real.$w$spowImpl" | Just r <- powImplWorker args -> reduce r+ "GHC.Real.$w$spowImpl1" | Just r <- powImplWorker args -> reduce r "GHC.Real.^_$sf2" -- :: Int# -> Integer -> Integer | [intLiteral -> Just j, integerLiteral -> Just i] <- args -> reduce (catchErrorCall (integerToIntLiteral $ i ^ j))@@ -2115,9 +2107,14 @@ | [i, j] <- integerLiterals' args -> reduce (Literal (IntegerLiteral (andInteger i j))) + -- On GHC >= 9.14 the bignum module moved into ghc-internal; the worker+ -- name follows. "GHC.Num.Integer.$wintegerFromInt64#" | [i] <- int64Literals' args -> reduce . Literal $ IntLiteral i+ "GHC.Internal.Bignum.Integer.$wintegerFromInt64#"+ | [i] <- int64Literals' args+ -> reduce . Literal $ IntLiteral i $(namePat 'GHC.Base.eqString) | [PrimVal _ _ [Lit (StringLiteral s1)]@@ -4637,9 +4634,15 @@ , Left (Literal (IntLiteral (toInteger len)))]) in reduce ret -- XXX: Does not seem to exist?+ -- 'noinlineConstraint' (if it exists) is a wired-in magic Id; not+ -- user-importable and so not TH-quotable. Match both the pre-9.14+ -- 'GHC.Magic' and the post-9.14 'GHC.Internal.Magic' module names. "GHC.Magic.noinlineConstraint" | [arg] <- args -> reduce (valToTerm arg)+ "GHC.Internal.Magic.noinlineConstraint"+ | [arg] <- args+ -> reduce (valToTerm arg) $(namePat 'GHC.TypeNats.withSomeSNat) | Lit (NaturalLiteral n) : fun : _ <- args , _ : funTy : _ <- Either.rights (fst (splitFunForallTy ty))@@ -4651,9 +4654,15 @@ ret = mkApps (valToTerm fun) [Right nTy, Left snat] in reduce ret -- XXX: Does not seem to exist?+ -- 'nospec' is a wired-in magic Id; not user-importable and so not+ -- TH-quotable. Match both the pre-9.14 'GHC.Magic' and the post-9.14+ -- 'GHC.Internal.Magic' module names. "GHC.Magic.nospec" | [arg] <- args -> reduce (valToTerm arg)+ "GHC.Internal.Magic.nospec"+ | [arg] <- args+ -> reduce (valToTerm arg) "GHC.Float.$wproperFractionDouble" | _ : Lit (DoubleLiteral d) : _ <- args , [sty@(tyView -> TyConApp signedTcNm [nTy@(LitTy (NumTy kn))])] <- tys@@ -4750,6 +4759,39 @@ catchDivByZero = makeUndefinedIf (==DivideByZero) catchErrorCall = makeUndefinedIf (const True :: ErrorCall -> Bool)++ -- Implementation shared by every worker of GHC's powImpl, i.e. the+ -- internal function behind '(^)'.+ --+ -- GHC's powImpl workers come in five flavors and get renumbered across+ -- versions: the (numeric-suffix -> signature) mapping changes between+ -- 9.10, 9.12 and 9.14, and may shift again. Rather than hard-code a+ -- fragile name->signature table, we register this single implementation+ -- under every worker name and dispatch by argument shape: the worker+ -- name is known, but which specialization it implements is inferred+ -- from the arg literals.+ --+ -- Shapes:+ -- [Int#, Integer] -> Integer (small-exponent path, IS exp#)+ -- [Int#, Int#] -> Int# (Int -> Int -> Int spec, $w$*)+ -- [Integer, Int#] -> Integer (Integer -> Int -> Integer spec, $w$*)+ -- [ByteArray#, Integer]-> Integer (large-exponent path, IP/IN)+ --+ -- For the ByteArray# variant we reconstruct the exponent as a positive+ -- bignum (IP ba). The negative-bignum (IN) arm is in practice dead: (^)+ -- errors on negative exponents before recursing, so reducing IN+ -- positively only affects DCE-able code.+ powImplWorker :: [Value] -> Maybe Term+ powImplWorker = \case+ [intLiteral -> Just j, integerLiteral -> Just i]+ -> Just (catchErrorCall (integerToIntegerLiteral $ i ^ j))+ [integerLiteral -> Just i, intLiteral -> Just j]+ -> Just (catchErrorCall (integerToIntegerLiteral $ i ^ j))+ [intLiteral -> Just i, intLiteral -> Just j]+ -> Just (catchErrorCall (integerToIntLiteral $ i ^ j))+ [Lit (ByteArrayLiteral (BA.ByteArray ba)), integerLiteral -> Just i]+ -> Just (catchErrorCall (integerToIntegerLiteral $ i ^ IP ba))+ _ -> Nothing -- Helper functions for literals
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}@@ -51,6 +52,11 @@ import Data.Text (Text, pack) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8)+import Data.Text.Extra (showt)+import qualified GHC.Magic+import qualified GHC.Prim+import qualified GHC.Stack+import qualified GHC.Stack.Types import qualified Data.Traversable as T import Data.String.Interpolate (__i) import qualified Text.Read as Text@@ -69,12 +75,16 @@ import GHC.Core (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), Alt(..),- collectArgs, rhssOfAlts, unfoldingTemplate)+#if MIN_VERSION_ghc(9,14,0)+ isTypeArg, isValArg,+#endif+ collectArgs, rhssOfAlts) import GHC.Types.Tickish (GenTickish (..)) import GHC.Core.DataCon- (DataCon, dataConExTyCoVars, dataConName, dataConRepArgTys, dataConTag,- dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConFieldLabels, flLabel,- HsImplBang(..), dataConImplBangs)+ (DataCon, dataConExTyCoVars, dataConName,+ dataConRepArgTys,+ dataConTag, dataConTyCon, dataConUnivTyVars, dataConWorkId,+ dataConFieldLabels, flLabel, HsImplBang(..), dataConImplBangs) import GHC.Core.FamInstEnv ( FamInst (..), FamInstEnvs , familyInstances, normaliseType, emptyFamInstEnvs, topReduceTyFamApp_maybe@@ -94,7 +104,13 @@ (AlgTyConRhs (..), TyCon, tyConName, algTyConRhs, isAlgTyCon, isFamilyTyCon, isNewTyCon, isPrimTyCon, isTupleTyCon, isClosedSynFamilyTyConWithAxiom_maybe, expandSynTyCon_maybe, tyConArity,- tyConDataCons, tyConKind, tyConName, tyConUnique, isClassTyCon, isPromotedDataCon_maybe)+ tyConDataCons, tyConKind,+#if MIN_VERSION_ghc(9,14,0)+ tyConTyVars,+ isUnaryClassTyCon,+#endif+ tyConUnique, isClassTyCon,+ isPromotedDataCon_maybe) import GHC.Core.TyCon (ExpandSynResult (..)) import GHC.Core.Type (tyConAppFunTy_maybe) import GHC.Core.Type (mkTvSubstPrs, substTy, coreView)@@ -270,7 +286,7 @@ mkAlgTyCon = do tcName <- coreToName tyConName tyConUnique qualifiedNameString tc tcKind <- coreToType (tyConKind tc)- tcRhsM <- makeAlgTyConRhs $ algTyConRhs tc+ tcRhsM <- makeAlgTyConRhs tc $ algTyConRhs tc case tcRhsM of Just tcRhs -> return@@ -357,9 +373,32 @@ ty <- coreToType (fi_rhs fi) return (tys,ty) -makeAlgTyConRhs :: AlgTyConRhs+makeAlgTyConRhs :: TyCon+ -> AlgTyConRhs -> C2C (Maybe C.AlgTyConRhs)-makeAlgTyConRhs algTcRhs = case algTcRhs of+makeAlgTyConRhs _tc algTcRhs = case algTcRhs of+#if MIN_VERSION_ghc(9,14,0)+ -- GHC 9.14 represents unary classes (a class with a single method or a single+ -- superclass) with their own AlgTyConRhs constructor instead of as a newtype.+ -- See Note [Unary class magic] in GHC.Core.TyCon. We map it back to Clash's+ -- 'NewTyCon' so that the wrapper data constructor (e.g. 'C:KnownNat') is+ -- treated as identity by clash's normalizer, which is what its semantics is.+ UnaryClassTyCon {data_con = dc} -> do+ let tvs = tyConTyVars _tc+ -- The DataCon for a unary class has exactly one field; that's the+ -- newtype's RHS (e.g. 'SNat n' for 'KnownNat n').+ rhsEtad = case dataConRepArgTys dc of+ [scaled] -> scaledThing scaled+ args -> error [__i|+ makeAlgTyConRhs: UnaryClassTyCon DataCon does not have one field+ Type constructor: #{showPprUnsafe _tc}+ Data constructor: #{showPprUnsafe dc}+ Representation argument types (#{length args}): #{showPprUnsafe args}+ |]+ Just <$> (C.NewTyCon <$> coreToDataCon dc+ <*> ((,) <$> mapM coreToTyVar tvs+ <*> coreToType rhsEtad))+#endif DataTyCon {data_cons = dcs} -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs SumTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs @@ -381,6 +420,26 @@ where term :: CoreExpr -> C2C C.Term term e+#if MIN_VERSION_ghc(9,14,0)+ -- See Note [Unary class magic] in GHC.Core.TyCon. The worker for a unary+ -- class data constructor (e.g. 'C:KnownNat') is semantically the identity+ -- on its single value field. Peel it off here so that downstream+ -- transformations (in particular the evaluator's literal extractors) see+ -- the underlying value directly, as they would have on GHC < 9.14 when+ -- unary classes were represented as newtypes.+ -- Match a fully-saturated worker application: all type args, then+ -- exactly one value arg. A naive '[Type _, val]' pattern would also+ -- match a partial application like 'C:IP @"callStack" @CallStack'+ -- (two 'Type' args, no value yet), binding 'val' to a 'Type' node+ -- and producing '_TY_'-wrapped junk when peeled.+ | (Var x, args) <- collectArgs e+ , Just dc <- isDataConId_maybe x+ , isUnaryClassTyCon (dataConTyCon dc)+ , (tyArgs, [val]) <- break isValArg args+ , all isTypeArg tyArgs+ , isValArg val+ = term val+#endif | (Var x,args) <- collectArgs e , let (nm, _) = RWS.evalRWS (qualifiedNameString (varName x)) (GHC2CoreEnv noSrcSpan emptyFamInstEnvs)@@ -406,17 +465,21 @@ | length args == 4 = term (args!!3) --- Remove `$`- go "GHC.Base.$" args- | length args == 5+ go nm args+ | nm == showt '($), length args == 5 = term (App (args!!3) (args!!4))- go "GHC.Magic.noinline" args -- noinline :: forall a. a -> a- | [_ty, x] <- args+ go nm args -- noinline :: forall a. a -> a+ | nm == showt 'GHC.Magic.noinline, [_ty, x] <- args = term x -- Remove most CallStack logic- go "GHC.Stack.Types.PushCallStack" args = term (last args)- go "GHC.Stack.Types.FreezeCallStack" args = term (last args)- go "GHC.Stack.withFrozenCallStack" args- | length args == 3+ go nm args+ | nm == showt 'GHC.Stack.Types.PushCallStack+ = term (last args)+ go nm args+ | nm == showt 'GHC.Stack.Types.FreezeCallStack+ = term (last args)+ go nm args+ | nm == showt 'GHC.Stack.withFrozenCallStack, length args == 3 = term (App (args!!2) (args!!1)) go "Clash.Sized.BitVector.Internal.checkUnpackUndef" args | [_nTy,_aTy,_kn,_typ,f] <- args@@ -590,9 +653,9 @@ then let xInfo = idInfo x unfolding = unfoldingInfo xInfo in case unfolding of- CoreUnfolding {} -> do+ CoreUnfolding {uf_tmpl} -> do sp <- view srcSpan- RWS.censor (const (SrcSpanRB sp)) (term (unfoldingTemplate unfolding))+ RWS.censor (const (SrcSpanRB sp)) (term uf_tmpl) NoUnfolding -> error ("No unfolding for DC wrapper: " ++ showPprUnsafe x) _ -> error ("Unexpected unfolding for DC wrapper: " ++ showPprUnsafe x) else C.Data <$> coreToDataCon dc@@ -606,12 +669,17 @@ | f == "Clash.Signal.Internal.traverse#" -> return (traverseTerm xType) | f == "Clash.Signal.Internal.joinSignal#" -> return (joinTerm xType) | f == "Clash.Signal.Bundle.vecBundle#" -> return (vecUnwrapTerm xType)- | f == "GHC.Base.$" -> return (dollarTerm xType)- | f == "GHC.Stack.withFrozenCallStack" -> return (withFrozenCallStackTerm xType)- | f == "GHC.Magic.noinline" -> return (idTerm xType)- | f == "GHC.Magic.lazy" -> return (idTerm xType)- | f == "GHC.Magic.nospec" -> return (idTerm xType)- | f == "GHC.Magic.runRW#" -> return (runRWTerm xType)+ | f == showt '($) -> return (dollarTerm xType)+ | f == showt 'GHC.Stack.withFrozenCallStack -> return (withFrozenCallStackTerm xType)+ | f == showt 'GHC.Magic.noinline -> return (idTerm xType)+ | f == showt 'GHC.Magic.lazy -> return (idTerm xType)+ -- 'nospec' is a wired-in magic Id in 'GHC.Magic' (resp.+ -- 'GHC.Internal.Magic' on GHC >= 9.14). It is not user-importable,+ -- so we can't quote it via TH. Both module names need a literal+ -- match here so that this clause fires across GHC versions.+ | f == "GHC.Magic.nospec" -> return (idTerm xType)+ | f == "GHC.Internal.Magic.nospec" -> return (idTerm xType)+ | f == showt 'GHC.Magic.runRW# -> return (runRWTerm xType) | f == "Clash.Sized.Internal.BitVector.checkUnpackUndef" -> return (checkUnpackUndefTerm xType) | f == "Clash.Magic.prefixName" -> return (nameModTerm C.PrefixName xType)@@ -847,11 +915,11 @@ -- | Try to determine boolean value by looking at constructor name of type. boolTypeToBool :: Type -> C2C Bool boolTypeToBool (TyConApp constructor _args) = do- constructorName <- typeConstructorToString constructor+ constructorName <- Text.pack <$> typeConstructorToString constructor return $ case constructorName of- "GHC.Types.True" -> True- "GHC.Types.False" -> False- _ -> error $ "Expected boolean constructor, got:" ++ constructorName+ _ | constructorName == showt 'True -> True+ | constructorName == showt 'False -> False+ | otherwise -> error $ "Expected boolean constructor, got:" ++ Text.unpack constructorName boolTypeToBool s = error $ unwords [ "Could not unpack given type to bool:" , showPprUnsafe s ]@@ -1440,7 +1508,7 @@ = let fName = C.mkUnsafeSystemName "f" 0 fId = C.mkLocalId fTy fName- rwNm = pack "GHC.Prim.realWorld#"+ rwNm = showt 'GHC.Prim.realWorld# in C.TyLam rTV ( C.TyLam oTV (
src-ghc/Clash/GHC/LoadInterfaceFiles.hs view
@@ -438,8 +438,8 @@ let _idInfo = Var.idInfo _id unfolding = IdInfo.realUnfoldingInfo _idInfo in case unfolding of- CoreSyn.CoreUnfolding {} ->- Just (CoreSyn.unfoldingTemplate unfolding)+ CoreSyn.CoreUnfolding {uf_tmpl} ->+ Just uf_tmpl CoreSyn.DFunUnfolding dfbndrs dc es -> Just (MkCore.mkCoreLams dfbndrs (MkCore.mkCoreConApps dc es)) CoreSyn.NoUnfolding
src-ghc/Clash/GHC/LoadModules.hs view
@@ -45,7 +45,9 @@ import Control.Monad.Catch as MC (try) import Control.Monad.IO.Class (liftIO) import Data.Char (isDigit)+#if !MIN_VERSION_ghc(9,14,0) import Data.Generics.Uniplate.DataOnly (transform)+#endif import Data.Data (Data) import Data.Functor ((<&>)) import Data.Foldable (toList)@@ -91,8 +93,9 @@ import GHC.Data.Bool (OverridingBool) import GHC.Driver.Config.Tidy (initTidyOpts) import GHC.Driver.Errors.Types (GhcMessage(GhcTcRnMessage))+#if !MIN_VERSION_ghc(9,14,0) import GHC.Driver.Monad (modifySession)-import GHC.Unit.Env (addHomeModInfoToHug)+#endif import GHC.Unit.Home.ModInfo (HomeModInfo(HomeModInfo)) import GHC.Unit.Module.ModSummary (findTarget) import qualified GHC.Driver.Env as HscTypes@@ -136,6 +139,12 @@ import qualified GHC.Unit.Module.Env as ModuleEnv import qualified GHC.Types.Name.Env as NameEnv +#if MIN_VERSION_ghc(9,14,0)+import GHC.Unit.Home.Graph (addHomeModInfoToHug)+#else+import GHC.Unit.Env (addHomeModInfoToHug)+#endif+ -- Internal Modules import Clash.GHC.GHC2Core (modNameM, qualifiedNameString') import Clash.GHC.LoadInterfaceFiles@@ -327,7 +336,10 @@ _ -> False -- If the build is already dynamic, dynamic objects get built anyway and GHC -- warns about '-dynamic-too' being ignored. See #3354.- targetIsDynamic = DynFlags.ways dflags2 `Ways.hasWay` Ways.WayDyn+ targetIsDynamic =+ DynFlags.ways dflags2 `Ways.hasWay` Ways.WayDyn+ || (Ways.hostIsDynamic+ && not (DynFlags.gopt DynFlags.Opt_ExternalInterpreter dflags2)) dflags3 = if ghcDynamic && not targetIsDynamic then DynFlags.gopt_set dflags2 DynFlags.Opt_BuildDynamicToo else dflags2@@ -370,11 +382,17 @@ let modGraph' = GHC.mapMG disableOptimizationsFlags modGraph -- 'topSortModuleGraph' ensures that modGraph2, and hence tidiedMods -- are in topological order, i.e. the root module is last.- modGraph2 = Digraph.flattenSCCs $- -- TODO: this might break backpack- Graph.filterToposortToModules $- GHC.topSortModuleGraph True modGraph' Nothing-+ modGraph2 =+#if MIN_VERSION_ghc(9,14,0)+ mapMaybe+ (\case+ Graph.ModuleNodeCompile ms -> Just ms+ _ -> Nothing) $+#endif+ Digraph.flattenSCCs $+ -- TODO: this might break backpack+ Graph.filterToposortToModules $+ GHC.topSortModuleGraph True modGraph' Nothing liftIO $ mapM_ checkMonoLocalBindsMod modGraph2 tidiedMods <- forM modGraph2 $ \m -> do@@ -449,7 +467,11 @@ (homeMod_bytecode linkable)) let linkable2 = linkable {homeMod_bytecode = linkable1} let mod_info = HomeModInfo iface details linkable2+#if MIN_VERSION_ghc(9,14,0)+ liftIO $ addHomeModInfoToHug mod_info (HscTypes.hsc_HUG hsc_env)+#else modifySession $ HscTypes.hscUpdateHUG (addHomeModInfoToHug mod_info)+#endif let pgm = HscTypes.cg_binds tidy_guts let modFamInstEnv = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcMod _ <- GHC.setSessionDynFlags oldDFlags@@ -1087,8 +1109,14 @@ #if MIN_VERSION_ghc(9,10,0) rmGConDetails :: GHC.HsConDeclGADTDetails GHC.GhcPs -> GHC.HsConDeclGADTDetails GHC.GhcPs+#if MIN_VERSION_ghc(9,14,0)+ rmGConDetails (GHC.PrefixConGADT tkn args) = GHC.PrefixConGADT tkn (fmap rmConDeclF args)+ rmGConDetails (GHC.RecConGADT tkn rec) =+ GHC.RecConGADT tkn ((fmap . fmap . fmap) rmConDeclRecF rec)+#else rmGConDetails (GHC.PrefixConGADT tkn args) = GHC.PrefixConGADT tkn (fmap rmHsScaledType args) rmGConDetails (GHC.RecConGADT tkn rec) = GHC.RecConGADT tkn ((fmap . fmap . fmap) rmConDeclF rec)+#endif #else rmGConDetails :: GHC.HsConDeclGADTDetails GHC.GhcPs -> GHC.HsConDeclGADTDetails GHC.GhcPs rmGConDetails (GHC.PrefixConGADT args) = GHC.PrefixConGADT (fmap rmHsScaledType args)@@ -1097,30 +1125,52 @@ -- type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name]) -- rmConDetails :: _ => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name+#if MIN_VERSION_ghc(9,14,0)+ rmConDetails (GHC.PrefixCon args) = GHC.PrefixCon (fmap rmConDeclF args)+ rmConDetails (GHC.InfixCon l r) = GHC.InfixCon (rmConDeclF l) (rmConDeclF r)+ rmConDetails (GHC.RecCon rec) = GHC.RecCon ((fmap . fmap . fmap) rmConDeclRecF rec)+#else rmConDetails (GHC.PrefixCon tys args) = GHC.PrefixCon tys (fmap rmHsScaledType args) rmConDetails (GHC.InfixCon l r) = GHC.InfixCon (rmHsScaledType l) (rmHsScaledType r) rmConDetails (GHC.RecCon rec) = GHC.RecCon ((fmap . fmap . fmap) rmConDeclF rec)+#endif +#if MIN_VERSION_ghc(9,14,0)+ rmHsType = id++ -- rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name+ rmConDeclF cdf =+ cdf+ { GHC.cdf_unpack = GHC.NoSrcUnpack+ , GHC.cdf_bang = GHC.NoSrcStrict+ , GHC.cdf_type = rmHsType (GHC.cdf_type cdf)+ }++ rmConDeclRecF (GHC.HsConDeclRecField ext names spec) =+ GHC.HsConDeclRecField ext names (rmConDeclF spec)+ rmConDeclRecF x@(GHC.XConDeclRecField _) = x+#else -- rmHsType :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name) rmHsType = transform go where- go ::- GHC.LBangType GHC.GhcPs ->- GHC.LBangType GHC.GhcPs+ -- go ::+ -- GHC.LBangType GHC.GhcPs ->+ -- GHC.LBangType GHC.GhcPs go (GHC.unLoc -> GHC.HsBangTy _ _ ty) = ty go ty = ty rmHsScaledType = transform go where- go ::- GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs) ->- GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)+ -- go ::+ -- GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs) ->+ -- GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs) go (GHC.HsScaled m (GHC.unLoc -> GHC.HsBangTy _ _ ty)) = GHC.HsScaled m ty go ty = ty -- rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name rmConDeclF cdf = cdf {GHC.cd_fld_type = rmHsType (GHC.cd_fld_type cdf)}+#endif -- | The package id of the clash-prelude we were built with preludePkgId :: String@@ -1136,7 +1186,11 @@ (x:_) -> throw (ClashException noSrcSpan (msgWrongPrelude x) Nothing) where pkgs = HscTypes.dep_direct_pkgs . HscTypes.mg_deps $ guts+#if MIN_VERSION_ghc(9,14,0)+ pkgIds = map (UnitTypes.unitIdString . snd) (toList pkgs)+#else pkgIds = map (UnitTypes.unitIdString) (toList pkgs)+#endif prelude = "clash-prelude-" isPrelude pkg = case splitAt (length prelude) pkg of (x,y:_) | x == prelude && isDigit y -> True -- check for a digit so we don't match clash-prelude-extras
src-ghc/Clash/GHC/NetlistTypes.hs view
@@ -7,8 +7,11 @@ -} {-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnboxedTuples #-} module Clash.GHC.NetlistTypes (ghcTypeToHWType)@@ -22,6 +25,17 @@ import Control.Monad.Trans.Except (Except, ExceptT (..), mapExceptT, runExceptT, throwE) import Control.Monad.Trans.Maybe (MaybeT (..))+import GHC.Exts+ ( Addr#, ByteArray#, Char#, Double#, Float#+ , Int#, Int8#, Int16#, Int32#, Int64#+ , List+ , Word#, Word8#, Word16#, Word32#, Word64#+ )+import GHC.Int (Int8, Int16, Int32, Int64)+import GHC.Natural (Natural)+import qualified GHC.STRef+import qualified GHC.Stack.Types+import GHC.Word (Word8, Word16, Word32, Word64) import Language.Haskell.TH.Syntax (showName) import Clash.Core.DataCon (DataCon (..))@@ -66,115 +80,107 @@ return (FilteredHWType (Annotated attrs typ') areVoids) go reprs m ty@(tyView -> TyConApp tc args) = runMaybeT . runExceptT $- case nameOcc tc of- "GHC.Int.Int8" -> returnN (Signed 8)- "GHC.Int.Int16" -> returnN (Signed 16)- "GHC.Int.Int32" -> returnN (Signed 32)- "GHC.Int.Int64" ->- if iw < 64- then case tyConDataCons (UniqMap.find tc m) of- [dc] -> case dcArgTys dc of- [tyView -> TyConApp nm _]- | nameOcc nm == "GHC.Prim.Int#" ->- throwE $ unlines ["Int64 not supported in forced 32-bit mode on a 64-bit machine."- ,"Run Clash with `-fclash-intwidth=64`."- ]- | nameOcc nm == "GHC.Prim.Int64#" ->- returnN (Signed 64)- _ -> throwE $ $(curLoc) ++ "Int64 DC has unexpected amount of arguments"- _ -> throwE $ $(curLoc) ++ "Int64 TC has unexpected amount of DCs"- else returnN (Signed 64)- "GHC.Word.Word8" -> returnN (Unsigned 8)- "GHC.Word.Word16" -> returnN (Unsigned 16)- "GHC.Word.Word32" -> returnN (Unsigned 32)- "GHC.Word.Word64" ->- if iw < 64- then case tyConDataCons (UniqMap.find tc m) of- [dc] -> case dcArgTys dc of- [tyView -> TyConApp nm _]- | nameOcc nm == "GHC.Prim.Word#" ->- throwE $ unlines ["Word64 not supported in forced 32-bit mode on a 64-bit machine."- ,"Run Clash with `-fclash-intwidth=64`."- ]- | nameOcc nm == "GHC.Prim.Word64#" ->- returnN (Unsigned 64)- _ -> throwE $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments"- _ -> throwE $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs"- else returnN (Unsigned 64)- "GHC.Num.Integer.Integer" -> returnN (Signed iw)- "GHC.Num.Natural.Natural" -> returnN (Unsigned iw)- "GHC.Prim.Char#" -> returnN (Unsigned 21)- "GHC.Prim.Int#" -> returnN (Signed iw)- "GHC.Prim.Word#" -> returnN (Unsigned iw)- "GHC.Prim.Int8#" -> returnN (Signed 8)- "GHC.Prim.Int16#" -> returnN (Signed 16)- "GHC.Prim.Int32#" -> returnN (Signed 32)- "GHC.Prim.Int64#" -> returnN (Signed 64)- "GHC.Prim.Word8#" -> returnN (Unsigned 8)- "GHC.Prim.Word16#" -> returnN (Unsigned 16)- "GHC.Prim.Word32#" -> returnN (Unsigned 32)- "GHC.Prim.Word64#" -> returnN (Unsigned 64)- "GHC.Prim.Float#" -> returnN (BitVector 32)- "GHC.Prim.Double#" -> returnN (BitVector 64)- "GHC.Prim.ByteArray#" ->- throwE $ "Can't translate type: " ++ showPpr ty-- "GHC.Types.Bool" -> returnN Bool- "GHC.Types.Float" -> returnN (BitVector 32)- "GHC.Types.Double" -> returnN (BitVector 64)- "GHC.Prim.~#" -> returnN (Void Nothing)+ let occ = nameOcc tc in+ if | occ == showt ''Int8 -> returnN (Signed 8)+ | occ == showt ''Int16 -> returnN (Signed 16)+ | occ == showt ''Int32 -> returnN (Signed 32)+ | occ == showt ''Int64 ->+ if iw < 64+ then case tyConDataCons (UniqMap.find tc m) of+ [dc] -> case dcArgTys dc of+ [tyView -> TyConApp nm _]+ | nameOcc nm == showt ''Int# ->+ throwE $ unlines ["Int64 not supported in forced 32-bit mode on a 64-bit machine."+ ,"Run Clash with `-fclash-intwidth=64`."+ ]+ | nameOcc nm == showt ''Int64# ->+ returnN (Signed 64)+ _ -> throwE $ $(curLoc) ++ "Int64 DC has unexpected amount of arguments"+ _ -> throwE $ $(curLoc) ++ "Int64 TC has unexpected amount of DCs"+ else returnN (Signed 64)+ | occ == showt ''Word8 -> returnN (Unsigned 8)+ | occ == showt ''Word16 -> returnN (Unsigned 16)+ | occ == showt ''Word32 -> returnN (Unsigned 32)+ | occ == showt ''Word64 ->+ if iw < 64+ then case tyConDataCons (UniqMap.find tc m) of+ [dc] -> case dcArgTys dc of+ [tyView -> TyConApp nm _]+ | nameOcc nm == showt ''Word# ->+ throwE $ unlines ["Word64 not supported in forced 32-bit mode on a 64-bit machine."+ ,"Run Clash with `-fclash-intwidth=64`."+ ]+ | nameOcc nm == showt ''Word64# ->+ returnN (Unsigned 64)+ _ -> throwE $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments"+ _ -> throwE $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs"+ else returnN (Unsigned 64)+ | occ == showt ''Integer -> returnN (Signed iw)+ | occ == showt ''Natural -> returnN (Unsigned iw)+ | occ == showt ''Char# -> returnN (Unsigned 21)+ | occ == showt ''Int# -> returnN (Signed iw)+ | occ == showt ''Word# -> returnN (Unsigned iw)+ | occ == showt ''Int8# -> returnN (Signed 8)+ | occ == showt ''Int16# -> returnN (Signed 16)+ | occ == showt ''Int32# -> returnN (Signed 32)+ | occ == showt ''Int64# -> returnN (Signed 64)+ | occ == showt ''Word8# -> returnN (Unsigned 8)+ | occ == showt ''Word16# -> returnN (Unsigned 16)+ | occ == showt ''Word32# -> returnN (Unsigned 32)+ | occ == showt ''Word64# -> returnN (Unsigned 64)+ | occ == showt ''Float# -> returnN (BitVector 32)+ | occ == showt ''Double# -> returnN (BitVector 64)+ | occ == showt ''ByteArray# ->+ throwE $ "Can't translate type: " ++ showPpr ty - "Clash.Signal.Internal.Signal" ->- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m (args !! 1)+ | occ == showt ''Bool -> returnN Bool+ | occ == showt ''Float -> returnN (BitVector 32)+ | occ == showt ''Double -> returnN (BitVector 64)+ -- '(~#)' is a wired-in equality primtype; the host module path+ -- changed from 'GHC.Prim' (<= 9.12) to 'GHC.Internal.Prim' (>= 9.14).+ | occ `elem` ["GHC.Prim.~#", "GHC.Internal.Prim.~#"]+ -> returnN (Void Nothing) - "Clash.Signal.BiSignal.BiSignalIn" -> do- szTy <- case args of- [_, _, szTy] -> pure szTy- _ -> throwE $ $(curLoc) ++ "BiSignalIn TC has unexpected amount of arguments"- let fType ty1 = FilteredHWType ty1 []- (fType . BiDirectional In . BitVector . fromInteger) <$>- liftE (tyNatSize m szTy)+ | occ == "Clash.Signal.Internal.Signal" ->+ ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m (args !! 1) - "Clash.Signal.BiSignal.BiSignalOut" -> do- szTy <- case args of- [_, _, szTy] -> pure szTy- _ -> throwE $ $(curLoc) ++ "BiSignalOut TC has unexpected amount of arguments"- let fType ty1 = FilteredHWType ty1 []- (fType . Void . Just . BiDirectional Out . BitVector . fromInteger) <$>- liftE (tyNatSize m szTy)+ | occ == "Clash.Signal.BiSignal.BiSignalIn" -> do+ szTy <- case args of+ [_, _, szTy] -> pure szTy+ _ -> throwE $ $(curLoc) ++ "BiSignalIn TC has unexpected amount of arguments"+ let fType ty1 = FilteredHWType ty1 []+ (fType . BiDirectional In . BitVector . fromInteger) <$>+ liftE (tyNatSize m szTy) - -- XXX: this is a hack to get a KnownDomain from a KnownConfiguration- "GHC.Classes.(%,%)"- | [arg0@(tyView -> TyConApp kdNm _), arg1] <- args- , nameOcc kdNm == showt ''KnownDomain- -> case tyView arg1 of- TyConApp kdNm1 _- | nameOcc kdNm1 == showt ''KnownDomain- -> do k1 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg0))- k2 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg1))- returnN (Void (Just (Product "GHC.Classes.(%,%)" Nothing [k1,k2])))- where- stripVoid (Void (Just t)) = t- stripVoid t = t- _ -> ExceptT (MaybeT (go reprs m arg0))+ | occ == "Clash.Signal.BiSignal.BiSignalOut" -> do+ szTy <- case args of+ [_, _, szTy] -> pure szTy+ _ -> throwE $ $(curLoc) ++ "BiSignalOut TC has unexpected amount of arguments"+ let fType ty1 = FilteredHWType ty1 []+ (fType . Void . Just . BiDirectional Out . BitVector . fromInteger) <$>+ liftE (tyNatSize m szTy) - -- XXX: this is a hack to get a KnownDomain from a KnownConfiguration- "GHC.Classes.CTuple2"- | [arg0@(tyView -> TyConApp kdNm _), arg1] <- args- , nameOcc kdNm == showt ''KnownDomain- -> case tyView arg1 of+ -- XXX: this is a hack to get a KnownDomain from a KnownConfiguration.+ -- Constraint-tuple type constructors are internal names that move+ -- between modules across GHC versions ('GHC.Classes' <= 9.12 vs+ -- 'GHC.Internal.Classes' >= 9.14); both forms appear here.+ | occ `elem` [ "GHC.Classes.(%,%)", "GHC.Internal.Classes.(%,%)"+ , "GHC.Classes.CTuple2", "GHC.Internal.Classes.CTuple2"+ ]+ , [arg0@(tyView -> TyConApp kdNm _), arg1] <- args+ , nameOcc kdNm == showt ''KnownDomain+ -> case tyView arg1 of TyConApp kdNm1 _ | nameOcc kdNm1 == showt ''KnownDomain- -> do k1 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg0))+ -> do let stripVoid (Void (Just t)) = t+ stripVoid t = t+ k1 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg0)) k2 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg1))- returnN (Void (Just (Product "GHC.Classes.CTuple2" Nothing [k1,k2])))- where- stripVoid (Void (Just t)) = t- stripVoid t = t+ returnN (Void (Just (Product occ Nothing [k1,k2]))) _ -> ExceptT (MaybeT (go reprs m arg0)) - "Clash.Signal.Internal.KnownDomain"- -> case tyConDataCons (UniqMap.find tc m) of+ | occ == "Clash.Signal.Internal.KnownDomain"+ -> case tyConDataCons (UniqMap.find tc m) of [dc] -> case substArgTys dc args of [_knownSymbol, _knownNat, tyView -> TyConApp _ [_,dom]] -> case tyView (coreView m dom) of@@ -191,135 +197,138 @@ _ -> ExceptT (MaybeT (pure Nothing)) _ -> ExceptT (MaybeT (pure Nothing)) - "Clash.Signal.Internal.Clock"- | [tag0] <- args- -> do- tag1 <- domTag m tag0- returnN (Clock (pack tag1))+ | occ == "Clash.Signal.Internal.Clock"+ , [tag0] <- args+ -> do+ tag1 <- domTag m tag0+ returnN (Clock (pack tag1)) - "Clash.Signal.Internal.ClockN"- | [tag0] <- args- -> do- tag1 <- domTag m tag0- returnN (ClockN (pack tag1))+ | occ == "Clash.Signal.Internal.ClockN"+ , [tag0] <- args+ -> do+ tag1 <- domTag m tag0+ returnN (ClockN (pack tag1)) - "Clash.Signal.Internal.Reset"- | [tag0] <- args- -> do- tag1 <- domTag m tag0- returnN (Reset (pack tag1))+ | occ == "Clash.Signal.Internal.Reset"+ , [tag0] <- args+ -> do+ tag1 <- domTag m tag0+ returnN (Reset (pack tag1)) - "Clash.Signal.Internal.Enable"- | [tag0] <- args- -> do- tag1 <- domTag m tag0- returnN (Enable (pack tag1))+ | occ == "Clash.Signal.Internal.Enable"+ , [tag0] <- args+ -> do+ tag1 <- domTag m tag0+ returnN (Enable (pack tag1)) - "Clash.Sized.Internal.BitVector.Bit" -> returnN Bit+ | occ == "Clash.Sized.Internal.BitVector.Bit" -> returnN Bit - "Clash.Sized.Internal.BitVector.BitVector" | n0:_ <- args -> do- n <- liftE (tyNatSize m n0)- case n of- 0 -> returnN (Void (Just (BitVector (fromInteger n))))- _ -> returnN (BitVector (fromInteger n))+ | occ == "Clash.Sized.Internal.BitVector.BitVector"+ , n0:_ <- args -> do+ n <- liftE (tyNatSize m n0)+ case n of+ 0 -> returnN (Void (Just (BitVector (fromInteger n))))+ _ -> returnN (BitVector (fromInteger n)) - "Clash.Sized.Internal.Index.Index" | n0:_ <- args -> do- n <- liftE (tyNatSize m n0)- if n < 2- then returnN (Void (Just (Index (fromInteger n))))- else returnN (Index (fromInteger n))+ | occ == "Clash.Sized.Internal.Index.Index"+ , n0:_ <- args -> do+ n <- liftE (tyNatSize m n0)+ if n < 2+ then returnN (Void (Just (Index (fromInteger n))))+ else returnN (Index (fromInteger n)) - "Clash.Sized.Internal.Signed.Signed" | n0:_ <- args -> do- n <- liftE (tyNatSize m n0)- if n == 0- then returnN (Void (Just (Signed (fromInteger n))))- else returnN (Signed (fromInteger n))+ | occ == "Clash.Sized.Internal.Signed.Signed"+ , n0:_ <- args -> do+ n <- liftE (tyNatSize m n0)+ if n == 0+ then returnN (Void (Just (Signed (fromInteger n))))+ else returnN (Signed (fromInteger n)) - "Clash.Sized.Internal.Unsigned.Unsigned" | n0:_ <- args -> do- n <- liftE (tyNatSize m n0)- if n == 0- then returnN (Void (Just (Unsigned (fromInteger n))))- else returnN (Unsigned (fromInteger n))+ | occ == "Clash.Sized.Internal.Unsigned.Unsigned"+ , n0:_ <- args -> do+ n <- liftE (tyNatSize m n0)+ if n == 0+ then returnN (Void (Just (Unsigned (fromInteger n))))+ else returnN (Unsigned (fromInteger n)) - "Clash.Sized.Vector.Vec" -> case args of- [szTy,elTy] -> do- sz0 <- liftE (tyNatSize m szTy)- fElHWTy <- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m elTy+ | occ == "Clash.Sized.Vector.Vec" -> case args of+ [szTy,elTy] -> do+ sz0 <- liftE (tyNatSize m szTy)+ fElHWTy <- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m elTy - -- Treat Vec as a product type with a single constructor and N- -- constructor fields.- let sz1 = fromInteger sz0 :: Int- elHWTy = stripFiltered fElHWTy+ -- Treat Vec as a product type with a single constructor and N+ -- constructor fields.+ let sz1 = fromInteger sz0 :: Int+ elHWTy = stripFiltered fElHWTy - let- (isVoid, vecHWTy) =- case elHWTy of- Void {} -> (True, Void (Just (Vector sz1 elHWTy)))- _ | sz1 == 0 -> (True, Void (Just (Vector sz1 elHWTy)))- _ -> (False, Vector sz1 elHWTy)+ let+ (isVoid, vecHWTy) =+ case elHWTy of+ Void {} -> (True, Void (Just (Vector sz1 elHWTy)))+ _ | sz1 == 0 -> (True, Void (Just (Vector sz1 elHWTy)))+ _ -> (False, Vector sz1 elHWTy) - let filtered = [replicate sz1 (isVoid, fElHWTy)]- return (FilteredHWType vecHWTy filtered)- _ -> throwE $ $(curLoc) ++ "Vec TC has unexpected amount of arguments"+ let filtered = [replicate sz1 (isVoid, fElHWTy)]+ return (FilteredHWType vecHWTy filtered)+ _ -> throwE $ $(curLoc) ++ "Vec TC has unexpected amount of arguments" - "Clash.Explicit.BlockRam.Internal.MemBlob" -> case args of- [nTy,mTy] -> do- n0 <- liftE (tyNatSize m nTy)- m0 <- liftE (tyNatSize m mTy)- returnN (MemBlob (fromInteger n0) (fromInteger m0))- _ -> throwE $ $(curLoc) ++ "MemBlob TC has unexpected amount of arguments"+ | occ == "Clash.Explicit.BlockRam.Internal.MemBlob" -> case args of+ [nTy,mTy] -> do+ n0 <- liftE (tyNatSize m nTy)+ m0 <- liftE (tyNatSize m mTy)+ returnN (MemBlob (fromInteger n0) (fromInteger m0))+ _ -> throwE $ $(curLoc) ++ "MemBlob TC has unexpected amount of arguments" - "Clash.Sized.RTree.RTree" -> case args of- [szTy,elTy] -> do- sz0 <- liftE (tyNatSize m szTy)- fElHWTy <- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m elTy+ | occ == "Clash.Sized.RTree.RTree" -> case args of+ [szTy,elTy] -> do+ sz0 <- liftE (tyNatSize m szTy)+ fElHWTy <- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m elTy - -- Treat RTree as a product type with a single constructor and 2^N- -- constructor fields.- let sz1 = fromInteger sz0 :: Int- elHWTy = stripFiltered fElHWTy+ -- Treat RTree as a product type with a single constructor and 2^N+ -- constructor fields.+ let sz1 = fromInteger sz0 :: Int+ elHWTy = stripFiltered fElHWTy - let- (isVoid, vecHWTy) =- case elHWTy of- Void {} -> (True, Void (Just (RTree sz1 elHWTy)))- _ -> (False, RTree sz1 elHWTy)+ let+ (isVoid, vecHWTy) =+ case elHWTy of+ Void {} -> (True, Void (Just (RTree sz1 elHWTy)))+ _ -> (False, RTree sz1 elHWTy) - let filtered = [replicate (2^sz1) (isVoid, fElHWTy)]- return (FilteredHWType vecHWTy filtered)- _ -> throwE $ $(curLoc) ++ "RTree TC has unexpected amount of arguments"+ let filtered = [replicate (2^sz1) (isVoid, fElHWTy)]+ return (FilteredHWType vecHWTy filtered)+ _ -> throwE $ $(curLoc) ++ "RTree TC has unexpected amount of arguments" - "String" -> returnN String- "GHC.Prim.Addr#" -> returnN String- "GHC.Types.[]" | a0:_ <- args -> case tyView a0 of- (TyConApp (nameOcc -> "GHC.Types.Char") []) -> returnN String- _ -> throwE $ "Can't translate type: " ++ showPpr ty- "GHC.Types.List" | a0:_ <- args -> case tyView a0 of- (TyConApp (nameOcc -> "GHC.Types.Char") []) -> returnN String- _ -> throwE $ "Can't translate type: " ++ showPpr ty+ | occ == "String" -> returnN String+ | occ == showt ''Addr# -> returnN String+ | occ `elem` [showt ''[], showt ''List]+ , a0:_ <- args -> case tyView a0 of+ (TyConApp (nameOcc -> nm) [])+ | nm == showt ''Char -> returnN String+ _ -> throwE $ "Can't translate type: " ++ showPpr ty - -- To ensure that Clash doesn't get stuck working away callstacks that- -- never end up being used in the generated HDL.- "GHC.Stack.Types.CallStack" -> returnN (Void Nothing)- "GHC.Internal.Stack.Types.CallStack" -> returnN (Void Nothing)+ -- To ensure that Clash doesn't get stuck working away callstacks that+ -- never end up being used in the generated HDL.+ | occ == showt ''GHC.Stack.Types.CallStack -> returnN (Void Nothing) - "Clash.Explicit.SimIO.SimIO" | a0:_ <- args ->- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m a0+ | occ == "Clash.Explicit.SimIO.SimIO"+ , a0:_ <- args ->+ ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m a0 - "Clash.Explicit.SimIO.File" -> returnN FileType+ | occ == "Clash.Explicit.SimIO.File" -> returnN FileType - "Clash.Explicit.SimIO.Reg" -> case args of- [aTy] -> ExceptT (MaybeT (Just <$> coreTypeToHWType go reprs m aTy))- _ -> throwE $ $(curLoc) ++ "Reg TC has unexpected amount of arguments"+ | occ == "Clash.Explicit.SimIO.Reg" -> case args of+ [aTy] -> ExceptT (MaybeT (Just <$> coreTypeToHWType go reprs m aTy))+ _ -> throwE $ $(curLoc) ++ "Reg TC has unexpected amount of arguments" - "GHC.STRef.STRef" -> case args of- [_,aTy] -> ExceptT (MaybeT (Just <$> coreTypeToHWType go reprs m aTy))- _ -> throwE $ $(curLoc) ++ "STRef TC has unexpected amount of arguments"+ | occ == showt ''GHC.STRef.STRef -> case args of+ [_,aTy] -> ExceptT (MaybeT (Just <$> coreTypeToHWType go reprs m aTy))+ _ -> throwE $ $(curLoc) ++ "STRef TC has unexpected amount of arguments" - -- Anything that's wrapped in SimOnly should be elided when we generate HDL- "Clash.Magic.SimOnly" -> returnN (Void Nothing)+ -- Anything that's wrapped in SimOnly should be elided when we generate HDL+ | occ == "Clash.Magic.SimOnly" -> returnN (Void Nothing) - _ -> ExceptT (MaybeT (pure Nothing))+ | otherwise -> ExceptT (MaybeT (pure Nothing)) go _ _ _ = pure Nothing