clash-ghc 1.8.2 → 1.8.3
raw patch · 25 files changed
+20731/−13244 lines, 25 filesdep ~Win32dep ~clash-libdep ~clash-preludePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Win32, clash-lib, clash-prelude
API changes (from Hackage documentation)
Files
- CHANGELOG.md +42/−0
- README.md +10/−2
- clash-ghc.cabal +10/−8
- src-bin-9.10.1/Clash/GHCi/Leak.hs +85/−0
- src-bin-9.10.1/Clash/GHCi/UI.hs +4883/−0
- src-bin-9.10.1/Clash/GHCi/UI/Exception.hs +142/−0
- src-bin-9.10.1/Clash/GHCi/UI/Info.hs +409/−0
- src-bin-9.10.1/Clash/GHCi/UI/Monad.hs +575/−0
- src-bin-9.10.1/Clash/GHCi/Util.hs +16/−0
- src-bin-9.10.1/Clash/Main.hs +1240/−0
- src-bin-9.10.2/Clash/GHCi/Leak.hs +85/−0
- src-bin-9.10.2/Clash/GHCi/UI.hs +4902/−0
- src-bin-9.10.2/Clash/GHCi/UI/Exception.hs +142/−0
- src-bin-9.10.2/Clash/GHCi/UI/Info.hs +409/−0
- src-bin-9.10.2/Clash/GHCi/UI/Monad.hs +575/−0
- src-bin-9.10.2/Clash/GHCi/Util.hs +16/−0
- src-bin-9.10.2/Clash/Main.hs +1240/−0
- src-bin-9.10/Clash/GHCi/Leak.hs +0/−85
- src-bin-9.10/Clash/GHCi/UI.hs +0/−4883
- src-bin-9.10/Clash/GHCi/UI/Exception.hs +0/−142
- src-bin-9.10/Clash/GHCi/UI/Info.hs +0/−409
- src-bin-9.10/Clash/GHCi/UI/Monad.hs +0/−575
- src-bin-9.10/Clash/GHCi/Util.hs +0/−16
- src-bin-9.10/Clash/Main.hs +0/−1240
- src-ghc/Clash/GHC/Evaluator/Primitive.hs +5950/−5884
CHANGELOG.md view
@@ -1,5 +1,47 @@ # Changelog for the Clash project +## 1.8.3 *Oct 6th 2025*++Added:+* `Counter` instances for `Bool`, `Bit`, `Int`, `Int8`, `Int16`, `Int32`, `Int64`, `Word`, `Word8`, `Word16`, `Word32`, `Word64`, `Identity` and `Maybe`. [#2692](https://github.com/clash-lang/clash-compiler/pull/2692)+* The Vec type now has a [COMPLETE pragma](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pragmas.html#complete-pragma) to avoid incomplete pattern matches when using the `(:>)` pattern. [#3020](https://github.com/clash-lang/clash-compiler/pull/3020)+* RamOp now has an AutoReg instance. [#2792](https://github.com/clash-lang/clash-compiler/pull/2792)+* Added instance `NFDataX (SimOnly a)` [#2900](https://github.com/clash-lang/clash-compiler/pull/2900)+* Support for GHC 9.10 on Windows (macOS and Linux were already supported) [#2945](https://github.com/clash-lang/clash-compiler/pull/2945)+* Added a `BitPack` instance for `Char` [#2957](https://github.com/clash-lang/clash-compiler/pull/2957)+* Support for GHC 9.10.2 [#3003](https://github.com/clash-lang/clash-compiler/pull/3003)++Changed:+* Functions defined on `Clash.Class.Counter` are now public [#2692](https://github.com/clash-lang/clash-compiler/pull/2692)++Fixed:+* Clash hanging when rendering `Index n` literals, for large values of `n` [#2813](https://github.com/clash-lang/clash-compiler/issues/2813)+* Render overflowed Index literals as don't-cares in HDL [#2970](https://github.com/clash-lang/clash-compiler/pull/2970)+* Clash errors out when `Clash.Sized.Vector.splitAt` is compile-time evaluated in an illegal context [#2831]https://github.com/clash-lang/clash-compiler/issues/2831+* `Clash.Explicit.DDR`: [#2911](https://github.com/clash-lang/clash-compiler/pull/2911)+ - `ddrIn`: VHDL: Remove data input from sensitivity list of `ddrIn_neg_latch` register as it is superfluous. This should not affect functionality.+ - `ddrOut`: VHDL: Fix incorrect usage of `Enable` input when the domain is set to asynchronous resets. Deasserting the `Enable` exhibited wrong behavior before this fix.+* `Clash.Xilinx.DDR`: [#2911](https://github.com/clash-lang/clash-compiler/pull/2911)+ - These primitives only support clocks where the rising edge is the active edge. Using them in a domain with falling active edges now causes an error.+ - `oddr`: Fix VHDL and SystemVerilog erroring out during HDL generation+ - Symbols in HDL for both `iddr` and `oddr` were renamed to match their function.+* `Clash.Intel.DDR`: [#2911](https://github.com/clash-lang/clash-compiler/pull/2911)+ - These primitives only support clocks where the rising edge is the active edge. Using them in a domain with falling active edges now causes an error.+ - Fix rendering HDL. It variously errored out or generated non-working HDL.+ - Rendering HDL no longer causes Clash to issue a warning about an argument unused in Haskell but used in the primitive black box.+* `makeTopEntity` now accounts for `SimOnly` constructs. This can prevent warnings in situtations where the `SimOnly` type would contain types `makeTopEntity` cannot handle. [#2897](https://github.com/clash-lang/clash-compiler/pull/2897)+* Clash did not build on GHC 9.6.7 (but did on 9.6.6) [#2916](https://github.com/clash-lang/clash-compiler/issues/2916)+* Ignore `Tick`s in `TermLiteral Integer`, `TermLiteral Char`, `TermLiteral Natural`, and `TermLiteral (SNat n)` [#2925](https://github.com/clash-lang/clash-compiler/pull/2925)+* Fixed laziness issue in internal black box `imap_go` [#2542](https://github.com/clash-lang/clash-compiler/issues/2542)+* Clash's evaluator now uses `TemplateHaskell` names to detect renamed symbols in `GHC.*` and `Clash.*`. Fixes errors similar to `No blackbox found for: GHC.Internal.Base.eqString` [#2972](https://github.com/clash-lang/clash-compiler/issues/2972)+* No blackbox found for: `GHC.Internal.Control.Exception.Base.recSelError` on GHC 9.10 [#2966](https://github.com/clash-lang/clash-compiler/issues/2966)+* Verilog and System Verilog code gen bug for `map head` [#2809](https://github.com/clash-lang/clash-compiler/issues/2809)+* Error parsing blackbox: `Clash.Sized.Vector.head` [#2988](https://github.com/clash-lang/clash-compiler/issues/2988)+* Clash no longer duplicates included datafiles when component is instantiated multiple times [#3008](https://github.com/clash-lang/clash-compiler/issues/3008)+* Clash will no longer emit "no blackbox found for" `GHC.Real`'s exponentiation function if it is applied to constants [#3010](https://github.com/clash-lang/clash-compiler/pull/3010)+* Clash will no longer error out when converting `ensureSpine` on Clash number types to HDL [#3021](https://github.com/clash-lang/clash-compiler/issues/3021)+* Clash will no longer ignore Synthesize annotations when the function is used in an argument position [#3024](https://github.com/clash-lang/clash-compiler/issues/3024)+ ## 1.8.2 *Jan 3rd 2025* Added:
README.md view
@@ -27,5 +27,13 @@ * Support for multiple clock domains, with type safe clock domain crossing. -# Support-For updates and questions join the mailing list clash-language+subscribe@googlegroups.com or read the [forum](https://groups.google.com/d/forum/clash-language)+# Open-source community+Clash benefits from an active community. Whether you need a question answered or+want to contribute to open-source features, browse the features below to make+the most of Clash.++- [Discourse: long form discussions and questions](https://clash-lang.discourse.group/)+- [Discord: short form discussions and community chat room](https://discord.gg/rebGq25FB4)+- [Slack: short form discussions and questions](https://functionalprogramming.slack.com/archives/CPGMJFF50)+ (Invite yourself at [fpslack.com](https://fpslack.com))+- [Github: issue tracker](https://github.com/clash-lang/clash-compiler/issues)
clash-ghc.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-ghc-Version: 1.8.2+Version: 1.8.3 Synopsis: Clash: a functional hardware description language - GHC frontend Description: Clash is a functional hardware description language that borrows both its@@ -121,8 +121,10 @@ library import: common-options HS-Source-Dirs: src-ghc, src-bin-common- if impl(ghc >= 9.10.0)- HS-Source-Dirs: src-bin-9.10+ if impl(ghc >= 9.10.2)+ HS-Source-Dirs: src-bin-9.10.2+ elif impl(ghc >= 9.10.0)+ HS-Source-Dirs: src-bin-9.10.1 elif impl(ghc >= 9.8.0) HS-Source-Dirs: src-bin-9.8 elif impl(ghc >= 9.6.0)@@ -158,7 +160,7 @@ containers >= 0.5.4.0 && < 0.8, data-binary-ieee754 >= 0.4.4 && < 0.6, directory >= 1.2 && < 1.4,- extra >= 1.6 && < 1.8,+ extra >= 1.6 && < 1.9, filepath >= 1.3 && < 1.6, process >= 1.2 && < 1.7, hashable >= 1.1.2.3 && < 1.6,@@ -170,15 +172,15 @@ transformers >= 0.5.2.0 && < 0.7, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib == 1.8.2,- clash-prelude == 1.8.2,+ clash-lib == 1.8.3,+ clash-prelude == 1.8.3, ghc-typelits-extra >= 0.3.2 && < 0.5, ghc-typelits-knownnat >= 0.6 && < 0.8, ghc-typelits-natnormalise >= 0.6 && < 0.8, deepseq >= 1.3.0.2 && < 1.6, time >= 1.4.0.1 && < 1.15, ghc-boot >= 8.6.0 && < 9.11,- ghc-prim >= 0.3.1.0 && < 0.12,+ ghc-prim >= 0.3.1.0 && < 0.13, ghci >= 8.6.0 && < 9.11, uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0,@@ -211,7 +213,7 @@ CPP-Options: -DUSE_GHC_PATHS=1 if os(windows)- Build-Depends: Win32 >= 2.3.1 && < 2.14+ Build-Depends: Win32 >= 2.3.1 && < 2.15 else Build-Depends: unix >= 2.7.1 && < 2.9
+ src-bin-9.10.1/Clash/GHCi/Leak.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module Clash.GHCi.Leak+ ( LeakIndicators+ , getLeakIndicators+ , checkLeakIndicators+ ) where++import Control.Monad+import Data.Bits+import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)+import GHC+import GHC.Ptr (Ptr (..))+import Clash.GHCi.Util+import GHC.Driver.Env+import GHC.Driver.Ppr+import GHC.Utils.Outputable+import GHC.Unit.Module.ModDetails+import GHC.Unit.Home.ModInfo+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 $+ forM (eltsUDFM (hsc_HPT hsc_env)) $ \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.10.1/Clash/GHCi/UI.hs view
@@ -0,0 +1,4883 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++{-# 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+import GHC.Runtime.Debugger++-- The GHC interface+import GHC.Runtime.Interpreter+import GHCi.RemoteTypes+import GHCi.BreakArray( breakOn, breakOff )+import GHC.ByteCode.Types+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 )+import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) )+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Diagnostic+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..), TargetId(..),+ Resume, SingleStep, Ghc,+ GetDocsFailure(..), pushLogHookM,+ getModuleGraph, handleSourceError, ms_mod )+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 )+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 ( orElse, expectJust )+import GHC.Types.Name.Set+import GHC.Utils.Panic hiding ( showException, try )+import GHC.Utils.Misc+import qualified GHC.LanguageExtensions as LangExt+import GHC.Data.Bag (unitBag)+import qualified GHC.Data.Strict as Strict+import GHC.Types.Error++-- 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 Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy,+ 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.ModInfo++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 Clash.GHCi.Leak+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.Util (clashLibVersion, reportTimeDiff)+import Data.Proxy+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+ availableCommands :: [Command],+ shortHelpText :: String,+ fullHelpText :: String,+ defPrompt :: PromptFunction,+ defPromptCont :: PromptFunction+ }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+ GhciSettings {+ availableCommands = ghciCommands opts,+ shortHelpText = defShortHelpText,+ 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", keepGoingMulti' changeDirectory, completeFilename),+ ("check", keepGoing' checkModule, completeHomeModule),+ ("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", keepGoingMulti' editFile, completeFilename),+ ("enable", keepGoing enableCmd, noCompletion),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoingMulti help, noCompletion),+ ("history", keepGoingMulti historyCmd, noCompletion),+ ("info", keepGoingMulti' (info False), completeIdentifier),+ ("info!", keepGoingMulti' (info True), completeIdentifier),+ ("issafe", keepGoing' isSafeCmd, completeModule),+ ("ignore", keepGoing ignoreCmd, noCompletion),+ ("kind", keepGoingMulti' (kindOfType False), completeIdentifier),+ ("kind!", keepGoingMulti' (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", keepGoingMulti' reloadModule, noCompletion),+ ("reload!", keepGoingMulti' reloadModuleDefer, noCompletion),+ ("run", keepGoing runRun, completeFilename),+ ("script", keepGoing' scriptCmd, completeFilename),+ ("set", keepGoingMulti setCmd, completeSetOptions),+ ("seti", keepGoingMulti setiCmd, completeSeti),+ ("show", keepGoingMulti' showCmd, completeShowOptions),+ ("showi", keepGoing showiCmd, completeShowiOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoingMulti' 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++keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)+keepGoingMulti a str = keepGoingMulti' (lift . a) str++keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome+keepGoing' a str = do+ in_multi <- inMultiMode+ if in_multi+ then+ liftIO $ hPutStrLn stderr "Command is not supported (yet) in multi-mode"+ else+ a str+ return CmdSuccess++-- For commands which are actually support in multi-mode, initially just :reload+keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m CmdExecOutcome+keepGoingMulti' a str = a str >> return CmdSuccess++inMultiMode :: GhciMonad m => m Bool+inMultiMode = multiMode <$> getGHCiState++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)+keepGoingPaths a str+ = do case toArgsNoLoc str of+ Left err -> liftIO $ hPutStrLn stderr err >> return CmdSuccess+ Right args -> keepGoing' a args++defShortHelpText :: String+defShortHelpText = "use :? for help.\n"++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"+++ " :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+ -- This is a HACK to make sure dynflags are not overwritten when setting+ -- options. When GHCi is made properly multi component it should be removed.+ modifySession (\env -> hscSetActiveUnitId (hscActiveUnitId env) env)+ -- 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++ -- 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 dflags' = (xopt_set_unlessExplSpec+ LangExt.ExtendedDefaultRules xopt_set)+ . (xopt_set_unlessExplSpec+ LangExt.MonomorphismRestriction xopt_unset)+ $ dflags+ GHC.setInteractiveDynFlags dflags'+ _ <- GHC.setProgramDynFlags+ -- Set Opt_KeepGoing so that :reload loads as much as+ -- possible+ (gopt_set dflags Opt_KeepGoing)++ -- 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}}+ hsc_env <- GHC.getSession+ let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1+ 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 = [],+ multiMode = in_multi,+ 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,+ 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,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering,+ ifaceCache = empty_cache+ }++ return ()++{-+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.+-- Uses ~/.ghc (getAppUserDataDirectory) if it exists+-- If it doesn't, then it uses $XDG_DATA_HOME/ghc+-- Earlier we always used to use ~/.ghc, but we want+-- to gradually move to $XDG_DATA_HOME to respect the XDG specification+--+-- As a migration strategy, we will only create new directories in+-- the appropriate XDG location. However, we will use the old directory+-- if it already exists.+getAppDataFile :: FilePath -> IO (Maybe FilePath)+getAppDataFile file = do+ let new_path = tryIO (getXdgDirectory XdgConfig "clash") >>= \case+ Left _ -> pure Nothing+ Right dir -> flip catchIO (const $ return Nothing) $ do+ createDirectoryIfMissing False dir+ pure $ Just $ dir </> file++ e_old_path <- tryIO (getAppUserDataDirectory "clash")+ case e_old_path of+ Right old_path -> doesDirectoryExist old_path >>= \case+ True -> pure $ Just $ old_path </> file+ False -> new_path+ Left _ -> new_path++runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+ dflags <- getDynFlags+ let+ ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++ app_user_dir = liftIO $ getAppDataFile "clashi.conf"++ home_dir = do+ either_dir <- liftIO $ tryIO (getEnv "HOME")+ case either_dir of+ Right home -> return (Just (home </> ".clashi"))+ _ -> return 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 [ app_user_dir, home_dir ]+ 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 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+ -- Set different defaulting rules (See #280)+ 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) -> return (Just (currentDirectory </> ".clashi_history"))+ (True, _) -> liftIO $ getAppDataFile "clashi_history"+ _ -> return 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 d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString 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 <- liftIO $ do+ (code, out, err) <-+ readProcessWithExitCode+ cmd args ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ hPutStrLn stderr 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 $+ 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++ 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?+ 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+ pflags <- initParserOpts <$> GHC.getInteractiveDynFlags+ -- 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 find.+ set_pragmas pflags++ 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 =+ let stringbuf = stringToStringBuffer input+ (_msgs, loc_opts) = Header.getOptions pflags 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 (const True) 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 (const True) (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 (unitBag (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+ => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult+afterRunStmt step_here 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+ , isNothing mb_info ||+ step_here (GHC.resumeSpan first_resume) -> 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_here GHC.SingleStep Nothing >>=+ afterRunStmt step_here >> 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.BreakInfo -> m (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+ let md = GHC.breakInfo_module inf+ nm = GHC.breakInfo_number inf+ st <- getGHCiState+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),+ breakModule loc == md,+ breakTick loc == nm ]++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+ htxt <- short_help <$> getGHCiState+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stderr ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return CmdFailure+ NoLastCommand ->+ do liftIO $ hPutStr stderr ("there is no last command to perform\n"+ ++ htxt)+ 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)++getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++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))++getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ return $ Just $ GHC.getHistoryModule hist++-----------------------------------------------------------------------------+--+-- 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 :: GHC.GhcMonad m => Bool -> String -> m ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <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 = case toArgsNoLoc s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> doWithMain (doWithArgs args)+ 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`++-----------------------------------------------------------------------------+-- :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 $ isLoadedModSummary 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.ms_location 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 _ (':':_) = (liftIO $ hPutStrLn stderr+ "macro name cannot start with a colon")+ >> failIfExprEvalMode+defineMacro _ ('!':_) = (liftIO $ hPutStrLn stderr+ "macro name cannot start with an exclamation mark")+ >> failIfExprEvalMode+ -- little code duplication allows to grep error msg+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ isCommand <- isJust <$> lookupCommand' macro_name+ let check_newname+ | macro_name `elem` defined = throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))+ | isCommand = throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))+ | otherwise = return ()+ hint = " Use ':def!' to overwrite."++ unless overwrite check_newname+ -- 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 }++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 throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ 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++-----------------------------------------------------------------------------+-- :check++checkModule :: GhciMonad m => String -> m ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> printErrAndMaybeExit e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = assert (all isExternalName scope) $+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) Check++-----------------------------------------------------------------------------+-- :doc++docCmd :: GHC.GhcMonad m => String -> m ()+docCmd "" =+ throwGhcException (CmdLineError "syntax: ':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 "" =+ throwGhcException (CmdLineError "syntax: ':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 originalFlags to avoid leaking the associated HscEnv+ !originalFlags <- getDynFlags+ void $ GHC.setProgramDynFlags $+ setGeneralFlag' Opt_DeferTypeErrors originalFlags+ return originalFlags)+ (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+ (\_ -> load)++loadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag+loadModule fs = do+ (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)+ either (liftIO . Exception.throwIO) return result++-- | @:load@ command+loadModule_ :: GhciMonad m => [FilePath] -> m ()+loadModule_ fs = void $ loadModule (zip3 fs (repeat Nothing) (repeat Nothing))++loadModuleDefer :: GhciMonad m => [FilePath] -> m ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag+loadModule' 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+ doLoadAndCollectInfo Load LoadAllTargets++ 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+ targets <- mapM (\m -> GHC.guessTarget m Nothing 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 liftIO $ hPutStrLn stderr ("Module " ++ moduleNameString m ++ " not found")+ failIfExprEvalMode+ return False++ checkTargetFile :: GhciMonad m => String -> m Bool+ checkTargetFile f = do+ exists <- liftIO (doesFileExist f)+ unless exists $ do+ liftIO $ hPutStrLn stderr $ "File " ++ f ++ " not found"+ failIfExprEvalMode+ return exists++-- | @:unadd@ command+unAddModule :: GhciMonad m => [FilePath] -> m ()+unAddModule files = do+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing 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+ session <- GHC.getSession+ let home_unit = homeUnitId (hsc_home_unit session)+ ok <- doLoadAndCollectInfo Reload (loadTargets home_unit)+ when (failed ok) failIfExprEvalMode+ where+ loadTargets hu | null m = LoadAllTargets+ | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m))++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+ -- MP: :set +c code path only works in single package mode atm, hence+ -- this call to isLoaded is ok. collectInfo needs to be modified further to+ -- work with :set +c so I have punted on that for now.+ loaded <- filterM GHC.isLoaded (map ms_mod_name 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) (mkUnknownDiagnostic . GHCiMessage) 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) = isLoadedModSummary 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.ms_mod_name summary == m then Just summary else Nothing+ (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetFile f _ }+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) =+ if f == f' then Just summary else Nothing+ _ `matches` _ = Nothing++ load_this summary | m <- GHC.ms_mod 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 (GHC.moduleName 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 (unLoc $ ideclName d) (ideclPkgQual d)+ e <- MC.try $ GHC.findQualifiedModule pkgqual mod_name+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isMainUnitModule m))+ where+ mod_name = unLoc (ideclName d)++++modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> 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 mod+ pure $ if is_interpreted+ then ppr (GHC.ms_mod mod)+ else ppr (GHC.ms_mod mod)+ <+> parens (text $ normalise $ msObjFilePath 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 SDoc m () -> m ()+runExceptGhciMonad act = handleSourceError printGhciException $+ either handleErr pure =<<+ runExceptT act+ where+ handleErr sdoc = do+ rendered <- showSDocForUserQualify sdoc+ liftIO $ hPutStrLn stderr rendered+ failIfExprEvalMode++-- | 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 top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top+ _ -> []+ where+ go srcs = do+ dflags <- GHC.getSessionDynFlags+ goX dflags srcs `MC.finally` recover dflags++ goX dflags srcs = do+ -- Issue #439 step 1+ (dflagsX,_,_) <- parseDynamicFlagsCmdLine 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+ 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)] }++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: GhciMonad m => String -> m ()+typeAtCmd str = runExceptGhciMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ (info, ty) <- findType infos span' sample+ let mb_rdr_env = case modinfoRdrEnv info of+ Strict.Just rdrs -> Just rdrs+ Strict.Nothing -> Nothing+ 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 <- 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) <- 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 SDoc (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 SDoc (Int,String)+ readAsInt "" = Left "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++ readAsString :: String -> Either SDoc (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 = Left ("Couldn't read" <+> text (show s0) <+> "as String")++ skipWs1 :: String -> Either SDoc String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+++-- | 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+ _ -> throwGhcException (CmdLineError "syntax: :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 :: GHC.GhcMonad m => String -> m ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :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 : _ -> GHC.findQualifiedModule NoPkgQual 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+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- 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 = throwGhcException (CmdLineError "syntax: :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+ mapM_ addII (map mkIIModule starred ++ 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 modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual <- GHC.renameRawPkgQualM modname (ideclPkgQual d)+ m <- GHC.lookupQualifiedModule pkgqual modname+ when safe $ do+ t <- GHC.isModuleTrusted m+ when (not 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 []++ return prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = 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+ && (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) ->+ case toArgsNoLoc rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgsNoLoc rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ "syntax: set prompt <string>"+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ "syntax: :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+ _ -> case toArgsNoLoc str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> () <$ keepGoing' setOptions wds++setiCmd :: GhciMonad m => String -> m ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgsNoLoc str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++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)+ ))+ liftIO $ showDynFlags show_all dflags+++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 = throwGhcException+ (CmdLineError "syntax: :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 :: MonadIO m+ => (PromptFunction -> m ()) -> String -> String -> m ()+setPromptString fSetPrompt value err = do+ if null value+ then liftIO $ hPutStrLn stderr $ err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> liftIO $ hPutStrLn stderr+ "Can't parse prompt string. Use Haskell syntax."+ _ ->+ 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++-- | newDynFlags 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)+newDynFlags :: GhciMonad m => Bool -> [String] -> m ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ logger <- getLogger+ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts++ liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)+ when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)++ when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ GHC.setInteractiveDynFlags idflags1+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags++ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine dflags0 lopts+ must_reload <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ let interp = hscInterp hsc_env+ when (packageFlagsChanged dflags2 dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ -- Clear caches and eventually defined breakpoints. (#1620)+ clearCaches+ when must_reload $ do+ let units = preloadUnits (hsc_units hsc_env)+ liftIO $ Loader.loadPackages interp hsc_env units+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False Nothing+ -- and copy the package flags to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ packageFlags = packageFlags dflags2 }++ let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ dflags' = dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks+ }+ hsc_env' = hscSetFlags dflags' hsc_env++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'++ return ()++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ CmdLineError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case flagSuggestions ghciFlags f of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))+ ghciFlags = nubSort $ flagsForCompletion True++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+ dflags <- getDynFlags+ 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++ _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+ in throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: GHC.GhcMonad m => String -> m ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :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 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.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM isLoadedModSummary (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)++isLoadedModSummary :: GHC.GhcMonad m => ModSummary -> m Bool+isLoadedModSummary ms = GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms)++{-+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+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ text "--> " <> text (GHC.resumeStmt res)+ $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+ 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)+ where+ mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showUnits :: GHC.GhcMonad m => m ()+showUnits = do+ dflags <- getDynFlags+ 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 = do+ dflags <- getDynFlags+ 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 = getDynFlags >>= 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+ _ -> throwGhcException (CmdLineError "Syntax: :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,+ completeHomeModule, 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 => [ModuleName] -> Module -> m [String]+ bidsByModule nonquals mod = do+ (_, decls) <- getModBreak mod+ let bids = nub $ declPath <$> elems decls+ pure $ case (moduleName 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+ (_, decls) <- getModBreak mod+ 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.ms_mod_name) 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.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules++completeHomeModule = wrapIdentCompleterMod listHomeModules++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 (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++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 <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Strict.Nothing) GHC.SingleStep++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 -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src _) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ massert (inRange (bounds ticks) line)+ let enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd pan >= realSrcSpanEnd src]+ return . minimumBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd++traceCmd :: GhciMonad m => String -> m ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) 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' (const True) 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 => (SrcSpan -> Bool) -> SingleStep -> m ()+doContinue pre step = doContinue' pre step Nothing++doContinue' :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()+doContinue' pre step mbCnt= do+ runResult <- resume pre step mbCnt+ _ <- afterRunStmt pre 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+ let breakInfo = GHC.BreakInfo (breakModule loc) (breakTick loc)+ setupBreakpoint breakInfo 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.BreakInfo -> Int -> m()+setupBreakpoint loc count = do+ hsc_env <- GHC.getSession+ GHC.setupBreakpoint hsc_env loc 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+ (mn : _) -> do+ md <- lookupModuleName mn+ 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 Nothing (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+ let (mod_str, top_level, fun_str) = splitIdent inp+ mod_top_lvl = combineModIdent mod_str top_level+ mb_mod <- catch (lookupModuleInscope mod_top_lvl)+ (\(_ :: SomeException) -> lookupModuleInGraph mod_str)+ -- If the top-level name is not in scope, `lookupModuleInscope` will+ -- throw an exception, then lookup the module name in the module graph.+ mb_err_msg <- validateBP mod_str fun_str mb_mod+ case mb_err_msg of+ Just err_msg -> printForUser $+ text "Cannot set breakpoint on" <+> quotes (text inp)+ <> text ":" <+> err_msg+ Nothing -> do+ -- No errors found, go and set the breakpoint+ mb_mod_info <- GHC.getModuleInfo $ fromJust mb_mod+ let modBreaks = case mb_mod_info of+ (Just mod_info) -> GHC.modInfoModBreaks mod_info+ Nothing -> emptyModBreaks+ findBreakAndSet (fromJust mb_mod) $ findBreakForBind fun_str modBreaks+ where+ -- Try to lookup the module for an identifier that is in scope.+ -- `parseName` throws an exception, if the identifier is not in scope+ lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)+ lookupModuleInscope mod_top_lvl = do+ names <- GHC.parseName mod_top_lvl+ pure $ Just $ NE.head $ GHC.nameModule <$> names++ -- Lookup the Module of a module name in the module graph+ lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)+ lookupModuleInGraph mod_str = do+ graph <- GHC.getModuleGraph+ let hmods = ms_mod <$> GHC.mgModSummaries graph+ pure $ find ((== mod_str) . showModule) hmods++ -- Check validity of an identifier to set a breakpoint:+ -- 1. The module of the identifier must exist+ -- 2. the identifier must be in an interpreted module+ -- 3. the ModBreaks array for module `mod` must have an entry+ -- for the function+ validateBP :: GhciMonad m => String -> String -> Maybe Module+ -> m (Maybe SDoc)+ validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text+ (combineModIdent mod_str (Prelude.takeWhile (/= '.') fun_str)))+ <+> text "not in scope"+ validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing"+ validateBP _ fun_str (Just modl) = do+ isInterpr <- GHC.moduleIsInterpreted modl+ (_, decls) <- getModBreak modl+ mb_err_msg <- case isInterpr of+ False -> pure $ Just $ text "Module" <+> quotes (ppr modl)+ <+> text "is not interpreted"+ True -> case fun_str `elem` (declPath <$> elems decls) of+ False -> pure $ Just $+ text "No breakpoint found for" <+> quotes (text fun_str)+ <+> "in module" <+> quotes (ppr modl)+ True -> pure Nothing+ pure mb_err_msg++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+ setBreakFlag md tick True+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = RealSrcSpan pan Strict.Nothing+ , breakTick = tick+ , onBreakCmd = ""+ , breakEnabled = True+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+ listToMaybe (sortBy (flip compare `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ (ix,pan) | (ix, pan) <- ticks,+ GHC.srcSpanStartLine pan == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding. So we find all breakpoints+-- for+-- (a) this binder only (it maybe a top-level or a nested declaration)+-- (b) that do not have an enclosing breakpoint+findBreakForBind :: String -> GHC.ModBreaks -> TickArray+ -> [(BreakIndex,RealSrcSpan)]+findBreakForBind str_name modbreaks _ = filter (not . enclosed) ticks+ where+ ticks = [ (index, span)+ | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks),+ str_name == declPath decls,+ RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]+ enclosed (_,sp0) = any subspan ticks+ where subspan (_,sp) = sp /= sp0 &&+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (flip compare `on` snd) contains +++ sortBy (compare `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile pan == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine pan == line,+ GHC.srcSpanStartCol pan >= col ]++-- 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+ md <- lookupModuleName mn+ listModuleLine md (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 (Just (GHC.srcLocFile l))+ (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+ Nothing -> panic "listModuleLine"+ Just summ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | 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+ (ticks, _) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GhciMonad m => m ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]+ where+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]++-- 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 = hme { homeUnitEnv_hpt = emptyHomePackageTable }+ discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG }+ modifySession (discardMG . discardIC . hscUpdateHUG (unitEnv_map pruneHomeUnitEnv))+++-- 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 (breakModule loc) (breakTick loc) onOff+ return loc { breakEnabled = onOff }++getModBreak :: GHC.GhcMonad m+ => Module -> m (Array Int SrcSpan, Array Int [String])+getModBreak m = do+ mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let ticks = GHC.modBreaks_locs modBreaks+ let decls = GHC.modBreaks_decls modBreaks+ return (ticks, decls)++setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m ()+setBreakFlag md ix enaDisa = do+ let enaDisaToCount True = breakOn+ enaDisaToCount False = breakOff+ setupBreakpoint (GHC.BreakInfo md ix) $ enaDisaToCount enaDisa++-- ---------------------------------------------------------------------------+-- 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 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 = (>> failIfExprEvalMode) . printGhciException++-----------------------------------------------------------------------------+-- 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 = GHC.lookupQualifiedModule NoPkgQual mName++isMainUnitModule :: Module -> Bool+isMainUnitModule m = GHC.moduleUnit m == mainUnit++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+ let str = moduleNameString modname+ home_unit <- hsc_home_unit <$> GHC.getSession+ unless (isHomeModule home_unit modl) $+ 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++++-- Split up a string with an eventually qualified declaration name into 3 components+-- 1. module name+-- 2. top-level decl+-- 3. full-name of the eventually nested decl, but without module qualification+-- eg "foo" = ("", "foo", "foo")+-- "A.B.C.foo" = ("A.B.C", "foo", "foo")+-- "M.N.foo.bar" = ("M.N", "foo", "foo.bar")+splitIdent :: String -> (String, String, String)+splitIdent [] = ("", "", "")+splitIdent inp@(a : _)+ | (isUpper a) = case fixs of+ [] -> (inp, "", "")+ (i1 : [] ) -> (upto i1, from i1, from i1)+ (i1 : i2 : _) -> (upto i1, take (i2 - i1 - 1) (from i1), from i1)+ | otherwise = case ixs of+ [] -> ("", inp, inp)+ (i1 : _) -> ("", upto i1, inp)+ where+ ixs = elemIndices '.' inp -- indices of '.' in whole input+ fixs = dropWhile isNextUc ixs -- indices of '.' in function names --+ isNextUc ix = isUpper $ safeInp !! (ix+1)+ safeInp = inp ++ " "+ upto i = take i inp+ from i = drop (i + 1) inp++-- Qualify an identifier name with a module name+-- combineModIdent "A" "foo" = "A.foo"+-- combineModIdent "" "foo" = "foo"+combineModIdent :: String -> String -> String+combineModIdent mod ident+ | null mod = ident+ | null ident = mod+ | otherwise = mod ++ "." ++ ident
+ src-bin-9.10.1/Clash/GHCi/UI/Exception.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Clash.GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where++import GHC.Prelude++import GHC.Driver.Config.Diagnostic+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Session++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+import GHC.Types.SourceError++import GHC.Unit.State++import GHC.Utils.Logger+import GHC.Utils.Outputable++import Control.Monad.IO.Class+++-- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting+-- for some error messages.+printGhciException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()+printGhciException err = do+ dflags <- getDynFlags+ logger <- getLogger+ let !diag_opts = initDiagOpts dflags+ !print_config = initPrintConfig dflags+ liftIO $ printMessages logger print_config diag_opts (GHCiMessage <$> (srcErrorMessages err))+++newtype GHCiMessage = GHCiMessage { _getGhciMessage :: GhcMessage }++instance Diagnostic GHCiMessage where+ type DiagnosticOpts GHCiMessage = DiagnosticOpts GhcMessage++ diagnosticMessage opts (GHCiMessage msg) = ghciDiagnosticMessage opts msg++ diagnosticReason (GHCiMessage msg) = diagnosticReason msg++ diagnosticHints (GHCiMessage msg) = ghciDiagnosticHints msg++ diagnosticCode (GHCiMessage msg) = diagnosticCode msg+++-- | 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.)"
+ src-bin-9.10.1/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,409 @@+{-# 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.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++-- | 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 :: !(Strict.Maybe 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 ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ name' <- findName infos span0 info string++ case getSrcSpan name' of+ UnhelpfulSpan{} -> do+ throwE ("Found a name, but no location information." <+>+ "The module is:" <+>+ maybe "<unknown>" (ppr . moduleName)+ (nameModule_maybe name'))++ span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc 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 ModuleName ModInfo+ -> RealSrcSpan+ -> ModInfo+ -> String+ -> ExceptT SDoc 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 "Couldn't resolve to any modules."+ 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 ModuleName ModInfo+ -> Name+ -> ExceptT SDoc m Name+resolveNameFromModule infos name = do+ modL <- maybe (throwE $ "No module for" <+> ppr name) return $+ nameModule_maybe name++ info <- maybe (throwE (ppr (moduleUnit modL) <> ":" <>+ ppr modL)) return $+ M.lookup (moduleName modL) infos++ let all_names = modInfo_rdrs info++ maybe (throwE "No matching export in any local modules.") return $+ 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 ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo, Type)+findType infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ 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 ModuleName ModInfo -> FilePath -> MaybeT m ModuleName+guessModule infos fp = do+ target <- lift $ guessTarget fp Nothing Nothing+ case targetId target of+ TargetModule mn -> return mn+ TargetFile fp' _ -> guessModule' fp'+ where+ guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName+ guessModule' fp' = case findModByFp fp' of+ Just mn -> return mn+ Nothing -> do+ fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++ target' <- lift $ guessTarget fp'' Nothing Nothing+ case targetId target' of+ TargetModule mn -> return mn+ _ -> MaybeT . pure $ findModByFp fp''++ findModByFp :: FilePath -> Maybe ModuleName+ findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+ where+ mifp :: (ModuleName, ModInfo) -> Maybe FilePath+ mifp = ml_hs_file . ms_location . modinfoSummary . snd+++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]+ -> m (Map ModuleName 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) => ModuleName -> m ModInfo+getModInfo name = do+ m <- getModSummary name+ p <- parseModule m+ typechecked <- typecheckModule p+ let allTypes = processAllTypeCheckedModule typechecked+ module_info = tm_checked_module_info typechecked+ !rdr_env = case modInfoRdrEnv module_info of+ Just rdrs -> Strict.Just rdrs+ -- NB: this has already been deeply forced; no need to do that again.+ -- See test case T15369 and Note [Forcing GREInfo] in GHC.Types.GREInfo.+ Nothing -> Strict.Nothing+ ts <- liftIO $ getModificationTime $ srcFilePath m+ return $+ ModInfo+ { modinfoSummary = m+ , modinfoSpans = allTypes+ , modinfoRdrEnv = rdr_env+ , modinfoLastUpdate = ts+ }++-- | Get the 'Name's from the 'GlobalRdrEnv' of the 'ModInfo', if any.+modInfo_rdrs :: ModInfo -> [Name]+modInfo_rdrs mi =+ case modinfoRdrEnv mi of+ Strict.Nothing -> []+ Strict.Just env -> map greName $ globalRdrEnvElts env++-- | 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 (HsWrap _ 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.10.1/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,575 @@+{-# LANGUAGE FlexibleInstances, DeriveFunctor, DerivingVia #-}+{-# 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,++ printForUserNeverQualify,+ printForUserModInfo, printForUserGlobalRdrEnv,+ printForUser, printForUserPartWay, 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.Types.Name.Reader+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 qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx)+import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)+import GHC.Runtime.Interpreter+import GHC.Runtime.Context+import GHCi.RemoteTypes+import Clash.GHCi.UI.Exception (printGhciException)+import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import GHC.Hs.Utils+import GHC.Utils.Misc+import GHC.Utils.Logger++import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)+import Numeric+import Data.Array+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++-----------------------------------------------------------------------------+-- 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,+ multiMode :: Bool,+ 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.+ 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)++ short_help :: String,+ -- ^ help text to display to a user+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)],++ mod_infos :: !(Map ModuleName ModInfo),++ flushStdHandles :: ForeignHValue,+ -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+ noBuffering :: ForeignHValue,+ -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+ ifaceCache :: ModIfaceCache+ }++type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]++-- | 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 } = throwM e+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+ { breakModule :: !GHC.Module+ , breakLoc :: !SrcSpan+ , breakTick :: {-# UNPACK #-} !Int+ , breakEnabled:: !Bool+ , onBreakCmd :: String+ }++instance Eq BreakLocation where+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+ breakTick loc1 == breakTick 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 $ breakModule 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) })++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- GHC.getInteractiveDynFlags+ liftIO $ Ppr.printForUser dflags stdout neverQualify AllTheWay doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info = printForUserGlobalRdrEnv (GHC.modInfoRdrEnv info)++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.printForUser 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++-- | 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 => (SrcSpan -> Bool) -> GHC.SingleStep -> Maybe Int -> m GHC.ExecResult+resume canLogSpan step mbIgnoreCnt = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec canLogSpan 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.10.1/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.10.1/Clash/Main.hs view
@@ -0,0 +1,1240 @@+{-# 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+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, compileFile )+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.Ways+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.Env+import GHC.Unit (UnitId, homeUnitDepends)+import GHC.Unit.Home.ModInfo (emptyHomePackageTable)+import GHC.Unit.Module ( ModuleName, mkModuleName )+import GHC.Unit.Module.ModIface+import GHC.Unit.State ( pprUnits, pprUnitsSimple )+import GHC.Unit.Finder ( findImportedModule, FindResult(..) )+import qualified GHC.Unit.State as State+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.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Monad ( liftIO, mapMaybeM )+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.SysTools.BaseDir++import GHC.Iface.Load+import GHC.Iface.Recomp.Binary ( fingerprintBinMem )++import GHC.Tc.Utils.Monad ( initIfaceCheck )+import GHC.Iface.Errors.Ppr++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except (throwE, runExceptT)+import Data.Char+import Data.List ( partition, intercalate, (\\) )+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Maybe+import Prelude+import GHC.ResponseFile (expandResponse)+import Data.Bifunctor+import GHC.Data.Graph.Directed+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 GHC.Data.EnumSet as EnumSet+import 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 ->+ -- start our GHC session+ 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+ (dflags3, fileish_args, dynamicFlagWarnings) <-+ GHC.parseDynamicFlags logger2 dflags2 args'++-- Propagate -Werror to Clash+ liftIO . modifyIORef' clashOpts $ \opts ->+ opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }++ let dflags4 = if backendNeedsFullWays bcknd &&+ not (gopt Opt_ExternalInterpreter dflags3)+ then+ let platform = targetPlatform dflags3+ dflags3a = dflags3 { targetWays_ = hostFullWays }+ dflags3b = foldl gopt_set dflags3a+ $ concatMap (wayGeneralFlags platform)+ hostFullWays+ dflags3c = foldl gopt_unset dflags3b+ $ concatMap (wayUnsetGeneralFlags platform)+ hostFullWays+ in dflags3c+ else+ dflags3++ 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++ -- 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+ Nothing -> do+ case srcs of+ [] -> return []+ _ -> do+ s <- initMake srcs+ return $ map (uncurry (,Nothing,)) s+ interactiveUI (defaultGhciSettings clashOpts) hs_srcs maybe_expr+#endif+++-- -----------------------------------------------------------------------------+-- 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)+ && isInterpretiveMode mode+ && 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.)"))++-----------------------------------------------------------------------------+-- 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"++-- ----------------------------------------------------------------------------+-- 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+ 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))++initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)]+initMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++ hsc_env <- GHC.getSession++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot hsc_env NoStop srcs) >> return []+ else do++ o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x)+ non_hs_srcs+ dflags <- GHC.getSessionDynFlags+ let dflags' = dflags { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags }+ _ <- GHC.setSessionDynFlags dflags'+ return hs_srcs++-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.+removeRTS :: [String] -> [String]+removeRTS ("+RTS" : xs) =+ case dropWhile (/= "-RTS") xs of+ [] -> []+ (_ : ys) -> removeRTS ys+removeRTS (y:ys) = y : removeRTS ys+removeRTS [] = []++initMulti :: NE.NonEmpty String -> Ghc ([(String, Maybe UnitId, Maybe Phase)])+initMulti unitArgsFiles = do+ hsc_env <- GHC.getSession+ let logger = hsc_logger hsc_env+ initial_dflags <- GHC.getSessionDynFlags++ dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do+ when (verbosity initial_dflags > 2) (liftIO $ print f)+ args <- liftIO $ expandResponse [f]+ (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine initial_dflags (map (mkGeneralLocated f) (removeRTS args))+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)++ let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)+ dflags4 = offsetDynFlags dflags3++ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++ -- This is dubious as the whole unit environment won't be set-up correctly, but+ -- that doesn't matter for what we use it for (linking and oneShot)+ let dubious_hsc_env = hscSetFlags dflags4 hsc_env+ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, [])+ else do++ o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x)+ non_hs_srcs+ let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags4 }++ liftIO $ checkOptions DoMake dflags5 srcs objs []++ pure (dflags5, hs_srcs)++ let+ unitDflags = NE.map fst dynFlagsAndSrcs+ srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs+ (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs))++ checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))++ let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags+ home_units = unitEnv_keys initial_home_graph++ home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+ hue_flags = homeUnitEnv_dflags homeUnitEnv+ dflags = homeUnitEnv_dflags homeUnitEnv+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units++ updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants+ pure $ HomeUnitEnv+ { homeUnitEnv_units = unit_state+ , homeUnitEnv_unit_dbs = Just dbs+ , homeUnitEnv_dflags = updated_dflags+ , homeUnitEnv_hpt = emptyHomePackageTable+ , homeUnitEnv_home_unit = Just home_unit+ }++ checkUnitCycles initial_dflags home_unit_graph++ let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph+ unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }++ GHC.setSession final_hsc_env++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then do+ liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."+ liftIO $ exitWith (ExitFailure 1)+ else do++{-+ o_files <- liftIO $ mapMaybeM+ (\(src, uid, mphase) ->+ compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)+ )+ (concat non_hs_srcs)+ -}++ -- MP: This should probably modify dflags for each unit?+ --let dflags' = dflags { ldInputs = map (FileOption "") o_files+ -- ++ ldInputs dflags }+ return $ concat hs_srcs++-- | Check that we don't have multiple units with the same UnitId.++checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc ()+checkUnitCycles dflags graph = processSCCs sccs+ where+ mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId+ mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue))+ nodes = map mkNode (unitEnv_elts graph)++ sccs = stronglyConnCompFromEdgedVerticesOrd nodes++ processSCCs [] = return ()+ processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs+ processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)+++ cycle_err uids =+ hang (text "Units form a dependency cycle:")+ 2+ (one_err uids)++ one_err uids = vcat $+ (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)+ ++ [text "-" <+> ppr final]+ where+ start = init uids+ final = last uids++checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()+checkDuplicateUnits dflags flags =+ unless (null duplicate_ids)+ (throwGhcException $ CmdLineError $ showSDoc dflags multi_err)++ where+ uids = map (second homeUnitId_) flags+ deduplicated_uids = ordNubOn snd uids+ duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids)++ duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids++ one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp++ multi_err =+ hang (text "Multiple units with the same unit-id:")+ 2+ (vcat (map one_err duplicate_flags))+++offsetDynFlags :: DynFlags -> DynFlags+offsetDynFlags dflags =+ dflags { hiDir = c hiDir+ , objectDir = c objectDir+ , stubDir = c stubDir+ , hieDir = c hieDir+ , dumpDir = c dumpDir }++ where+ c f = augment_maybe (f dflags)++ augment_maybe Nothing = Nothing+ augment_maybe (Just f) = Just (augment f)+ augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f+ | otherwise = f+++createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> (HomeUnitGraph, UnitId)+createUnitEnvFromFlags unitDflags =+ let+ newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing+ unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags+ activeUnit = fst $ NE.head unitEnvList+ in+ (unitEnv_new (Map.fromList (NE.toList (unitEnvList))), activeUnit)++-- ---------------------------------------------------------------------------+-- 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 Paths_clash_ghc.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++ 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 . mi_final_exts) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showPpr dflags f)++-----------------------------------------------------------------------------+-- HDL Generation++makeHDL'+ :: forall backend+ . Clash.Backend.Backend backend+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [(String,Maybe Phase)]+ -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' proxy startAction r srcs = makeHDL proxy startAction r $ fmap 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)++-- -----------------------------------------------------------------------------+-- Util++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.10.2/Clash/GHCi/Leak.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module Clash.GHCi.Leak+ ( LeakIndicators+ , getLeakIndicators+ , checkLeakIndicators+ ) where++import Clash.GHCi.Util+import Control.Monad+import Data.Bits+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.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 $+ forM (eltsUDFM (hsc_HPT hsc_env)) $ \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.10.2/Clash/GHCi/UI.hs view
@@ -0,0 +1,4902 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++{-# 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+import GHC.Runtime.Debugger++-- The GHC interface+import GHC.Runtime.Interpreter+import GHCi.RemoteTypes+import GHCi.BreakArray( breakOn, breakOff )+import GHC.ByteCode.Types+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 )+import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) )+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Diagnostic+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..), TargetId(..),+ Resume, SingleStep, Ghc,+ GetDocsFailure(..), pushLogHookM,+ getModuleGraph, handleSourceError, ms_mod )+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.Breakpoint+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 )+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 ( orElse, expectJust )+import GHC.Types.Name.Set+import GHC.Utils.Panic hiding ( showException, try )+import GHC.Utils.Misc+import qualified GHC.LanguageExtensions as LangExt+import GHC.Data.Bag (unitBag)+import qualified GHC.Data.Strict as Strict+import GHC.Types.Error++-- 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 Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy,+ 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.ModInfo++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 Clash.GHCi.Leak+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.Util (clashLibVersion, reportTimeDiff)+import Data.Proxy+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+ availableCommands :: [Command],+ shortHelpText :: String,+ fullHelpText :: String,+ defPrompt :: PromptFunction,+ defPromptCont :: PromptFunction+ }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+ GhciSettings {+ availableCommands = ghciCommands opts,+ shortHelpText = defShortHelpText,+ 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", keepGoingMulti' changeDirectory, completeFilename),+ ("check", keepGoing' checkModule, completeHomeModule),+ ("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", keepGoingMulti' editFile, completeFilename),+ ("enable", keepGoing enableCmd, noCompletion),+ ("force", keepGoing forceCmd, completeExpression),+ ("forward", keepGoing forwardCmd, noCompletion),+ ("help", keepGoingMulti help, noCompletion),+ ("history", keepGoingMulti historyCmd, noCompletion),+ ("info", keepGoingMulti' (info False), completeIdentifier),+ ("info!", keepGoingMulti' (info True), completeIdentifier),+ ("issafe", keepGoing' isSafeCmd, completeModule),+ ("ignore", keepGoing ignoreCmd, noCompletion),+ ("kind", keepGoingMulti' (kindOfType False), completeIdentifier),+ ("kind!", keepGoingMulti' (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", keepGoingMulti' reloadModule, noCompletion),+ ("reload!", keepGoingMulti' reloadModuleDefer, noCompletion),+ ("run", keepGoing runRun, completeFilename),+ ("script", keepGoing' scriptCmd, completeFilename),+ ("set", keepGoingMulti setCmd, completeSetOptions),+ ("seti", keepGoingMulti setiCmd, completeSeti),+ ("show", keepGoingMulti' showCmd, completeShowOptions),+ ("showi", keepGoing showiCmd, completeShowiOptions),+ ("sprint", keepGoing sprintCmd, completeExpression),+ ("step", keepGoing stepCmd, completeIdentifier),+ ("steplocal", keepGoing stepLocalCmd, completeIdentifier),+ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),+ ("type", keepGoingMulti' 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++keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)+keepGoingMulti a str = keepGoingMulti' (lift . a) str++keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome+keepGoing' a str = do+ in_multi <- inMultiMode+ if in_multi+ then+ liftIO $ hPutStrLn stderr "Command is not supported (yet) in multi-mode"+ else+ a str+ return CmdSuccess++-- For commands which are actually support in multi-mode, initially just :reload+keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m CmdExecOutcome+keepGoingMulti' a str = a str >> return CmdSuccess++inMultiMode :: GhciMonad m => m Bool+inMultiMode = multiMode <$> getGHCiState++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)+keepGoingPaths a str+ = do case toArgsNoLoc str of+ Left err -> liftIO $ hPutStrLn stderr err >> return CmdSuccess+ Right args -> keepGoing' a args++defShortHelpText :: String+defShortHelpText = "use :? for help.\n"++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"+++ " :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+ -- This is a HACK to make sure dynflags are not overwritten when setting+ -- options. When GHCi is made properly multi component it should be removed.+ modifySession (\env -> hscSetActiveUnitId (hscActiveUnitId env) env)+ -- 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++ -- 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 dflags' = (xopt_set_unlessExplSpec+ LangExt.ExtendedDefaultRules xopt_set)+ . (xopt_set_unlessExplSpec+ LangExt.MonomorphismRestriction xopt_unset)+ $ dflags+ GHC.setInteractiveDynFlags dflags'+ _ <- GHC.setProgramDynFlags+ -- Set Opt_KeepGoing so that :reload loads as much as+ -- possible+ (gopt_set dflags Opt_KeepGoing)++ -- 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}}+ hsc_env <- GHC.getSession+ let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1+ 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 = [],+ multiMode = in_multi,+ 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,+ 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,+ short_help = shortHelpText config,+ long_help = fullHelpText config,+ lastErrorLocations = lastErrLocationsRef,+ mod_infos = M.empty,+ flushStdHandles = flush,+ noBuffering = nobuffering,+ ifaceCache = empty_cache+ }++ return ()++{-+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 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+ -- Set different defaulting rules (See #280)+ 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 d | Just m <- ideclAs d = unLoc m+ | otherwise = unLoc (ideclName d)++ modules_names =+ ['*':(moduleNameString 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 <- liftIO $ do+ (code, out, err) <-+ readProcessWithExitCode+ cmd args ""+ `catchIO` \e -> return (ExitFailure 1, "", show e)+ case code of+ ExitSuccess -> return out+ _ -> do+ hPutStrLn stderr 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 $+ 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++ 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?+ 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+ pflags <- initParserOpts <$> GHC.getInteractiveDynFlags+ -- 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 find.+ set_pragmas pflags++ 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 =+ let stringbuf = stringToStringBuffer input+ (_msgs, loc_opts) = Header.getOptions pflags 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 (const True) 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 (const True) (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 (unitBag (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+ => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult+afterRunStmt step_here 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+ , isNothing mb_info ||+ step_here (GHC.resumeSpan first_resume) -> 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_here GHC.SingleStep Nothing >>=+ afterRunStmt step_here >> 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+ return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),+ breakModule loc == ibi_tick_mod inf,+ breakTick loc == ibi_tick_index inf ]++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+ htxt <- short_help <$> getGHCiState+ case maybe_cmd of+ GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+ BadCommand ->+ do liftIO $ hPutStr stderr ("unknown command ':" ++ cmd ++ "'\n"+ ++ htxt)+ return CmdFailure+ NoLastCommand ->+ do liftIO $ hPutStr stderr ("there is no last command to perform\n"+ ++ htxt)+ 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)++getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)+getCurrentBreakSpan = do+ resumes <- GHC.getResumeContext+ case resumes of+ [] -> return Nothing+ (r:_) -> do+ let ix = GHC.resumeHistoryIx r+ if ix == 0+ then return (Just (GHC.resumeSpan r))+ else do+ let hist = GHC.resumeHistory r !! (ix-1)+ pan <- GHC.getHistorySpan hist+ return (Just pan)++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))++getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)+getCurrentBreakModule = do+ resumes <- GHC.getResumeContext+ return $ case resumes of+ [] -> Nothing+ (r:_) -> case GHC.resumeHistoryIx r of+ 0 -> ibi_tick_mod <$> GHC.resumeBreakpointId r+ ix -> Just $ GHC.getHistoryModule $ GHC.resumeHistory r !! (ix-1)++-----------------------------------------------------------------------------+--+-- 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 :: GHC.GhcMonad m => Bool -> String -> m ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <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 = case toArgsNoLoc s of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> doWithMain (doWithArgs args)+ 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`++-----------------------------------------------------------------------------+-- :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 $ isLoadedModSummary 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.ms_location 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 _ (':':_) = (liftIO $ hPutStrLn stderr+ "macro name cannot start with a colon")+ >> failIfExprEvalMode+defineMacro _ ('!':_) = (liftIO $ hPutStrLn stderr+ "macro name cannot start with an exclamation mark")+ >> failIfExprEvalMode+ -- little code duplication allows to grep error msg+defineMacro overwrite s = do+ let (macro_name, definition) = break isSpace s+ macros <- ghci_macros <$> getGHCiState+ let defined = map cmdName macros+ if null macro_name+ then if null defined+ then liftIO $ putStrLn "no macros defined"+ else liftIO $ putStr ("the following macros are defined:\n" +++ unlines defined)+ else do+ isCommand <- isJust <$> lookupCommand' macro_name+ let check_newname+ | macro_name `elem` defined = throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))+ | isCommand = throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))+ | otherwise = return ()+ hint = " Use ':def!' to overwrite."++ unless overwrite check_newname+ -- 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 }++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 throwGhcException (CmdLineError+ ("macro '" ++ macro_name ++ "' is not defined"))+ 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++-----------------------------------------------------------------------------+-- :check++checkModule :: GhciMonad m => String -> m ()+checkModule m = do+ let modl = GHC.mkModuleName m+ ok <- handleSourceError (\e -> printErrAndMaybeExit e >> return False) $ do+ r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+ dflags <- getDynFlags+ liftIO $ putStrLn $ showSDoc dflags $+ case GHC.moduleInfo r of+ cm | Just scope <- GHC.modInfoTopLevelScope cm ->+ let+ (loc, glob) = assert (all isExternalName scope) $+ partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+ in+ (text "global names: " <+> ppr glob) $$+ (text "local names: " <+> ppr loc)+ _ -> empty+ return True+ afterLoad (successIf ok) Check++-----------------------------------------------------------------------------+-- :doc++docCmd :: GHC.GhcMonad m => String -> m ()+docCmd "" =+ throwGhcException (CmdLineError "syntax: ':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 "" =+ throwGhcException (CmdLineError "syntax: ':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 originalFlags to avoid leaking the associated HscEnv+ !originalFlags <- getDynFlags+ void $ GHC.setProgramDynFlags $+ setGeneralFlag' Opt_DeferTypeErrors originalFlags+ return originalFlags)+ (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+ (\_ -> load)++loadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag+loadModule fs = do+ (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)+ either (liftIO . Exception.throwIO) return result++-- | @:load@ command+loadModule_ :: GhciMonad m => [FilePath] -> m ()+loadModule_ fs = void $ loadModule (zip3 fs (repeat Nothing) (repeat Nothing))++loadModuleDefer :: GhciMonad m => [FilePath] -> m ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag+loadModule' 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+ doLoadAndCollectInfo Load LoadAllTargets++ 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+ targets <- mapM (\m -> GHC.guessTarget m Nothing 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 liftIO $ hPutStrLn stderr ("Module " ++ moduleNameString m ++ " not found")+ failIfExprEvalMode+ return False++ checkTargetFile :: GhciMonad m => String -> m Bool+ checkTargetFile f = do+ exists <- liftIO (doesFileExist f)+ unless exists $ do+ liftIO $ hPutStrLn stderr $ "File " ++ f ++ " not found"+ failIfExprEvalMode+ return exists++-- | @:unadd@ command+unAddModule :: GhciMonad m => [FilePath] -> m ()+unAddModule files = do+ files' <- mapM expandPath files+ targets <- mapM (\m -> GHC.guessTarget m Nothing 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+ session <- GHC.getSession+ let home_unit = homeUnitId (hsc_home_unit session)+ ok <- doLoadAndCollectInfo Reload (loadTargets home_unit)+ when (failed ok) failIfExprEvalMode+ where+ loadTargets hu | null m = LoadAllTargets+ | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m))++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+ -- MP: :set +c code path only works in single package mode atm, hence+ -- this call to isLoaded is ok. collectInfo needs to be modified further to+ -- work with :set +c so I have punted on that for now.+ loaded <- filterM GHC.isLoaded (map ms_mod_name 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) (mkUnknownDiagnostic . GHCiMessage) 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) = isLoadedModSummary 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.ms_mod_name summary == m then Just summary else Nothing+ (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetFile f _ }+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) =+ if f == f' then Just summary else Nothing+ _ `matches` _ = Nothing++ load_this summary | m <- GHC.ms_mod 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 (GHC.moduleName 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+ case e :: Either SomeException Module of+ Left _ -> return False+ Right m -> return (not (isMainUnitModule m))+ 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.ModSummary] -> 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 mod+ pure $ if is_interpreted+ then ppr (GHC.ms_mod mod)+ else ppr (GHC.ms_mod mod)+ <+> parens (text $ normalise $ msObjFilePath 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 SDoc m () -> m ()+runExceptGhciMonad act = handleSourceError printGhciException $+ either handleErr pure =<<+ runExceptT act+ where+ handleErr sdoc = do+ rendered <- showSDocForUserQualify sdoc+ liftIO $ hPutStrLn stderr rendered+ failIfExprEvalMode++-- | 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 top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top+ _ -> []+ where+ go srcs = do+ dflags <- GHC.getSessionDynFlags+ goX dflags srcs `MC.finally` recover dflags++ goX dflags srcs = do+ -- Issue #439 step 1+ (dflagsX,_,_) <- parseDynamicFlagsCmdLine 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+ 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)] }++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: GhciMonad m => String -> m ()+typeAtCmd str = runExceptGhciMonad $ do+ (span',sample) <- exceptT $ parseSpanArg str+ infos <- lift $ mod_infos <$> getGHCiState+ (info, ty) <- findType infos span' sample+ let mb_rdr_env = case modinfoRdrEnv info of+ Strict.Just rdrs -> Just rdrs+ Strict.Nothing -> Nothing+ 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 <- 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) <- 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 SDoc (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 SDoc (Int,String)+ readAsInt "" = Left "Premature end of string while expecting Int"+ readAsInt s0 = case reads s0 of+ [s_rest] -> Right s_rest+ _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++ readAsString :: String -> Either SDoc (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 = Left ("Couldn't read" <+> text (show s0) <+> "as String")++ skipWs1 :: String -> Either SDoc String+ skipWs1 (c:cs) | isWs c = Right (skipWs cs)+ skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++ isWs = (`elem` [' ','\t'])+ skipWs = dropWhile isWs+ breakWs = break isWs+++-- | 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+ _ -> throwGhcException (CmdLineError "syntax: :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 :: GHC.GhcMonad m => String -> m ()+isSafeCmd m =+ case words m of+ [s] | looksLikeModuleName s -> do+ md <- lookupModule s+ isSafeModule md+ [] -> do md <- guessCurrentModule "issafe"+ isSafeModule md+ _ -> throwGhcException (CmdLineError "syntax: :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 : _ -> GHC.findQualifiedModule NoPkgQual 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+ let names+ | exports_only = GHC.modInfoExports mod_info+ | otherwise = GHC.modInfoTopLevelScope mod_info+ `orElse` []++ -- 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 = throwGhcException (CmdLineError "syntax: :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+ mapM_ addII (map mkIIModule starred ++ 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 modname+ | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+ | otherwise -> wantInterpretedModuleName modname >> return ()++ IIDecl d -> do+ let modname = unLoc (ideclName d)+ pkgqual <- GHC.renameRawPkgQualM modname (ideclPkgQual d)+ m <- GHC.lookupQualifiedModule 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 :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = 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+ && (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) ->+ case toArgsNoLoc rest of+ Left err -> liftIO (hPutStrLn stderr err)+ Right args -> setArgs args+ Right ("prog", rest) ->+ case toArgsNoLoc rest of+ Right [prog] -> setProg prog+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++ Right ("prompt", rest) ->+ setPromptString setPrompt (dropWhile isSpace rest)+ "syntax: set prompt <string>"+ Right ("prompt-function", rest) ->+ setPromptFunc setPrompt $ dropWhile isSpace rest+ Right ("prompt-cont", rest) ->+ setPromptString setPromptCont (dropWhile isSpace rest)+ "syntax: :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+ _ -> case toArgsNoLoc str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> () <$ keepGoing' setOptions wds++setiCmd :: GhciMonad m => String -> m ()+setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str =+ case toArgsNoLoc str of+ Left err -> liftIO (hPutStrLn stderr err)+ Right wds -> newDynFlags True wds++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)+ ))+ liftIO $ showDynFlags show_all dflags+++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 = throwGhcException+ (CmdLineError "syntax: :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 :: MonadIO m+ => (PromptFunction -> m ()) -> String -> String -> m ()+setPromptString fSetPrompt value err = do+ if null value+ then liftIO $ hPutStrLn stderr $ err+ else case value of+ ('\"':_) ->+ case reads value of+ [(value', xs)] | all isSpace xs ->+ setParsedPromptString fSetPrompt value'+ _ -> liftIO $ hPutStrLn stderr+ "Can't parse prompt string. Use Haskell syntax."+ _ ->+ 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++-- | newDynFlags 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)+newDynFlags :: GhciMonad m => Bool -> [String] -> m ()+newDynFlags interactive_only minus_opts = do+ let lopts = map noLoc minus_opts++ logger <- getLogger+ idflags0 <- GHC.getInteractiveDynFlags+ (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts++ liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)+ when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)++ when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+ liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+ GHC.setInteractiveDynFlags idflags1+ installInteractivePrint (interactivePrint idflags1) False++ dflags0 <- getDynFlags++ when (not interactive_only) $ do+ (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine dflags0 lopts+ must_reload <- GHC.setProgramDynFlags dflags1++ -- if the package flags changed, reset the context and link+ -- the new packages.+ hsc_env <- GHC.getSession+ let dflags2 = hsc_dflags hsc_env+ let interp = hscInterp hsc_env+ when (packageFlagsChanged dflags2 dflags0) $ do+ when (verbosity dflags2 > 0) $+ liftIO . putStrLn $+ "package flags have changed, resetting and loading new packages..."+ -- Clear caches and eventually defined breakpoints. (#1620)+ clearCaches+ when must_reload $ do+ let units = preloadUnits (hsc_units hsc_env)+ liftIO $ Loader.loadPackages interp hsc_env units+ -- package flags changed, we can't re-use any of the old context+ setContextAfterLoad False Nothing+ -- and copy the package flags to the interactive DynFlags+ idflags <- GHC.getInteractiveDynFlags+ GHC.setInteractiveDynFlags+ idflags{ packageFlags = packageFlags dflags2 }++ let ld0length = length $ ldInputs dflags0+ fmrk0length = length $ cmdlineFrameworks dflags0++ newLdInputs = drop ld0length (ldInputs dflags2)+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++ dflags' = dflags2 { ldInputs = newLdInputs+ , cmdlineFrameworks = newCLFrameworks+ }+ hsc_env' = hscSetFlags dflags' hsc_env++ when (not (null newLdInputs && null newCLFrameworks)) $+ liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'++ return ()++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ CmdLineError $ concatMap oneError fs+ where+ oneError f =+ "unrecognised flag: " ++ f ++ "\n" +++ (case flagSuggestions ghciFlags f of+ [] -> ""+ suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))+ ghciFlags = nubSort $ flagsForCompletion True++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+ dflags <- getDynFlags+ 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++ _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+ in throwGhcException $ CmdLineError $ showSDoc dflags+ $ hang (text "syntax:") 4+ $ hang (text ":show") 6+ $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: GHC.GhcMonad m => String -> m ()+showiCmd str = do+ case words str of+ ["languages"] -> showiLanguages -- backwards compat+ ["language"] -> showiLanguages+ ["lang"] -> showiLanguages -- useful abbreviation+ _ -> throwGhcException (CmdLineError ("syntax: :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 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.ModSummary]+getLoadedModules = do+ graph <- GHC.getModuleGraph+ filterM isLoadedModSummary (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)++isLoadedModSummary :: GHC.GhcMonad m => ModSummary -> m Bool+isLoadedModSummary ms = GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms)++{-+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+ printForUser $ vcat (map pp_resume (reverse resumes))+ where+ pp_resume res =+ text "--> " <> text (GHC.resumeStmt res)+ $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+ 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)+ where+ mb_mod_name = moduleName <$> ibi_tick_mod <$> GHC.resumeBreakpointId res++showUnits :: GHC.GhcMonad m => m ()+showUnits = do+ dflags <- getDynFlags+ 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 = do+ dflags <- getDynFlags+ 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 = getDynFlags >>= 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+ _ -> throwGhcException (CmdLineError "Syntax: :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,+ completeHomeModule, 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 => [ModuleName] -> Module -> m [String]+ bidsByModule nonquals mod = do+ (_, decls) <- getModBreak mod+ let bids = nub $ declPath <$> elems decls+ pure $ case (moduleName 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+ (_, decls) <- getModBreak mod+ 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.ms_mod_name) 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.ms_mod_name) getLoadedModules+ return $ loaded_mods ++ pkg_mods+ return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules++completeHomeModule = wrapIdentCompleterMod listHomeModules++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 (const True) GHC.SingleStep+ step expression = runStmt expression GHC.SingleStep >> return ()++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 <- enclosingTickSpan md loc+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Strict.Nothing) GHC.SingleStep++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 -> do+ let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+ doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src _) = do+ ticks <- getTickArray md+ let line = srcSpanStartLine src+ massert (inRange (bounds ticks) line)+ let enclosing_spans = [ pan | (_,pan) <- ticks ! line+ , realSrcSpanEnd pan >= realSrcSpanEnd src]+ return . minimumBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd++traceCmd :: GhciMonad m => String -> m ()+traceCmd arg+ = withSandboxOnly ":trace" $ tr arg+ where+ tr [] = doContinue (const True) 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' (const True) 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 => (SrcSpan -> Bool) -> SingleStep -> m ()+doContinue pre step = doContinue' pre step Nothing++doContinue' :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()+doContinue' pre step mbCnt= do+ runResult <- resume pre step mbCnt+ _ <- afterRunStmt pre 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+ let bi = GHC.BreakpointId+ { bi_tick_mod = breakModule loc+ , bi_tick_index = breakTick loc+ }+ setupBreakpoint bi 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 loc count = do+ hsc_env <- GHC.getSession+ GHC.setupBreakpoint hsc_env loc 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+ (mn : _) -> do+ md <- lookupModuleName mn+ 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 Nothing (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+ let (mod_str, top_level, fun_str) = splitIdent inp+ mod_top_lvl = combineModIdent mod_str top_level+ mb_mod <- catch (lookupModuleInscope mod_top_lvl)+ (\(_ :: SomeException) -> lookupModuleInGraph mod_str)+ -- If the top-level name is not in scope, `lookupModuleInscope` will+ -- throw an exception, then lookup the module name in the module graph.+ mb_err_msg <- validateBP mod_str fun_str mb_mod+ case mb_err_msg of+ Just err_msg -> printForUser $+ text "Cannot set breakpoint on" <+> quotes (text inp)+ <> text ":" <+> err_msg+ Nothing -> do+ -- No errors found, go and set the breakpoint+ mb_mod_info <- GHC.getModuleInfo $ fromJust mb_mod+ let modBreaks = case mb_mod_info of+ (Just mod_info) -> GHC.modInfoModBreaks mod_info+ Nothing -> emptyModBreaks+ findBreakAndSet (fromJust mb_mod) $ findBreakForBind fun_str modBreaks+ where+ -- Try to lookup the module for an identifier that is in scope.+ -- `parseName` throws an exception, if the identifier is not in scope+ lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)+ lookupModuleInscope mod_top_lvl = do+ names <- GHC.parseName mod_top_lvl+ pure $ Just $ NE.head $ GHC.nameModule <$> names++ -- Lookup the Module of a module name in the module graph+ lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)+ lookupModuleInGraph mod_str = do+ graph <- GHC.getModuleGraph+ let hmods = ms_mod <$> GHC.mgModSummaries graph+ pure $ find ((== mod_str) . showModule) hmods++ -- Check validity of an identifier to set a breakpoint:+ -- 1. The module of the identifier must exist+ -- 2. the identifier must be in an interpreted module+ -- 3. the ModBreaks array for module `mod` must have an entry+ -- for the function+ validateBP :: GhciMonad m => String -> String -> Maybe Module+ -> m (Maybe SDoc)+ validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text+ (combineModIdent mod_str (Prelude.takeWhile (/= '.') fun_str)))+ <+> text "not in scope"+ validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing"+ validateBP _ fun_str (Just modl) = do+ isInterpr <- GHC.moduleIsInterpreted modl+ (_, decls) <- getModBreak modl+ mb_err_msg <- case isInterpr of+ False -> pure $ Just $ text "Module" <+> quotes (ppr modl)+ <+> text "is not interpreted"+ True -> case fun_str `elem` (declPath <$> elems decls) of+ False -> pure $ Just $+ text "No breakpoint found for" <+> quotes (text fun_str)+ <+> "in module" <+> quotes (ppr modl)+ True -> pure Nothing+ pure mb_err_msg++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+ setBreakFlag md tick True+ (alreadySet, nm) <-+ recordBreak $ BreakLocation+ { breakModule = md+ , breakLoc = RealSrcSpan pan Strict.Nothing+ , breakTick = tick+ , onBreakCmd = ""+ , breakEnabled = True+ }+ printForUser $+ text "Breakpoint " <> ppr nm <>+ if alreadySet+ then text " was already set at " <> ppr pan+ else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+-- - the leftmost complete subexpression on the specified line, or+-- - the leftmost subexpression starting on the specified line, or+-- - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`+ listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+ listToMaybe (sortBy (flip compare `on` snd) ticks)+ where+ ticks = arr ! line++ starts_here = [ (ix,pan) | (ix, pan) <- ticks,+ GHC.srcSpanStartLine pan == line ]++ (comp, incomp) = partition ends_here starts_here+ where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding. So we find all breakpoints+-- for+-- (a) this binder only (it maybe a top-level or a nested declaration)+-- (b) that do not have an enclosing breakpoint+findBreakForBind :: String -> GHC.ModBreaks -> TickArray+ -> [(BreakIndex,RealSrcSpan)]+findBreakForBind str_name modbreaks _ = filter (not . enclosed) ticks+ where+ ticks = [ (index, span)+ | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks),+ str_name == declPath decls,+ RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]+ enclosed (_,sp0) = any subspan ticks+ where subspan (_,sp) = sp /= sp0 &&+ realSrcSpanStart sp <= realSrcSpanStart sp0 &&+ realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+ -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+ | not (inRange (bounds arr) line) = Nothing+ | otherwise =+ listToMaybe (sortBy (flip compare `on` snd) contains +++ sortBy (compare `on` snd) after_here)+ where+ ticks = arr ! line++ -- the ticks that span this coordinate+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col),+ is_correct_file pan ]++ is_correct_file pan+ | Just f <- mb_file = GHC.srcSpanFile pan == f+ | otherwise = True++ after_here = [ tick | tick@(_,pan) <- ticks,+ GHC.srcSpanStartLine pan == line,+ GHC.srcSpanStartCol pan >= col ]++-- 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+ md <- lookupModuleName mn+ listModuleLine md (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 (Just (GHC.srcLocFile l))+ (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+ Nothing -> panic "listModuleLine"+ Just summ -> do+ let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+ loc = mkRealSrcLoc (mkFastString (filename)) line 0+ listAround (realSrcLocSpan loc) False++-- | 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+ (ticks, _) <- getModBreak modl+ let arr = mkTickArray (assocs ticks)+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+ return arr++discardTickArrays :: GhciMonad m => m ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+ = accumArray (flip (:)) [] (1, max_line)+ [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]+ where+ max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]+ srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]++-- 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 = hme { homeUnitEnv_hpt = emptyHomePackageTable }+ discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG }+ modifySession (discardMG . discardIC . hscUpdateHUG (unitEnv_map pruneHomeUnitEnv))+++-- 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 (breakModule loc) (breakTick loc) onOff+ return loc { breakEnabled = onOff }++getModBreak :: GHC.GhcMonad m+ => Module -> m (Array Int SrcSpan, Array Int [String])+getModBreak m = do+ mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m+ let modBreaks = GHC.modInfoModBreaks mod_info+ let ticks = GHC.modBreaks_locs modBreaks+ let decls = GHC.modBreaks_decls modBreaks+ return (ticks, decls)++setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m ()+setBreakFlag md ix enaDisa = do+ let enaDisaToCount True = breakOn+ enaDisaToCount False = breakOff+ setupBreakpoint (GHC.BreakpointId md ix) $ enaDisaToCount enaDisa++-- ---------------------------------------------------------------------------+-- 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 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 = (>> failIfExprEvalMode) . printGhciException++-----------------------------------------------------------------------------+-- 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 = GHC.lookupQualifiedModule NoPkgQual mName++isMainUnitModule :: Module -> Bool+isMainUnitModule m = GHC.moduleUnit m == mainUnit++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+ let str = moduleNameString modname+ home_unit <- hsc_home_unit <$> GHC.getSession+ unless (isHomeModule home_unit modl) $+ 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++++-- Split up a string with an eventually qualified declaration name into 3 components+-- 1. module name+-- 2. top-level decl+-- 3. full-name of the eventually nested decl, but without module qualification+-- eg "foo" = ("", "foo", "foo")+-- "A.B.C.foo" = ("A.B.C", "foo", "foo")+-- "M.N.foo.bar" = ("M.N", "foo", "foo.bar")+splitIdent :: String -> (String, String, String)+splitIdent [] = ("", "", "")+splitIdent inp@(a : _)+ | (isUpper a) = case fixs of+ [] -> (inp, "", "")+ (i1 : [] ) -> (upto i1, from i1, from i1)+ (i1 : i2 : _) -> (upto i1, take (i2 - i1 - 1) (from i1), from i1)+ | otherwise = case ixs of+ [] -> ("", inp, inp)+ (i1 : _) -> ("", upto i1, inp)+ where+ ixs = elemIndices '.' inp -- indices of '.' in whole input+ fixs = dropWhile isNextUc ixs -- indices of '.' in function names --+ isNextUc ix = isUpper $ safeInp !! (ix+1)+ safeInp = inp ++ " "+ upto i = take i inp+ from i = drop (i + 1) inp++-- Qualify an identifier name with a module name+-- combineModIdent "A" "foo" = "A.foo"+-- combineModIdent "" "foo" = "foo"+combineModIdent :: String -> String -> String+combineModIdent mod ident+ | null mod = ident+ | null ident = mod+ | otherwise = mod ++ "." ++ ident
+ src-bin-9.10.2/Clash/GHCi/UI/Exception.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Clash.GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where++import GHC.Prelude++import GHC.Driver.Config.Diagnostic+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Session++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+import GHC.Types.SourceError++import GHC.Unit.State++import GHC.Utils.Logger+import GHC.Utils.Outputable++import Control.Monad.IO.Class+++-- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting+-- for some error messages.+printGhciException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()+printGhciException err = do+ dflags <- getDynFlags+ logger <- getLogger+ let !diag_opts = initDiagOpts dflags+ !print_config = initPrintConfig dflags+ liftIO $ printMessages logger print_config diag_opts (GHCiMessage <$> (srcErrorMessages err))+++newtype GHCiMessage = GHCiMessage { _getGhciMessage :: GhcMessage }++instance Diagnostic GHCiMessage where+ type DiagnosticOpts GHCiMessage = DiagnosticOpts GhcMessage++ diagnosticMessage opts (GHCiMessage msg) = ghciDiagnosticMessage opts msg++ diagnosticReason (GHCiMessage msg) = diagnosticReason msg++ diagnosticHints (GHCiMessage msg) = ghciDiagnosticHints msg++ diagnosticCode (GHCiMessage msg) = diagnosticCode msg+++-- | 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.)"
+ src-bin-9.10.2/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,409 @@+{-# 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.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++-- | 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 :: !(Strict.Maybe 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 ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ MaybeT $ pure $ M.lookup name infos++ name' <- findName infos span0 info string++ case getSrcSpan name' of+ UnhelpfulSpan{} -> do+ throwE ("Found a name, but no location information." <+>+ "The module is:" <+>+ maybe "<unknown>" (ppr . moduleName)+ (nameModule_maybe name'))++ span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+ => Map ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc 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 ModuleName ModInfo+ -> RealSrcSpan+ -> ModInfo+ -> String+ -> ExceptT SDoc 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 "Couldn't resolve to any modules."+ 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 ModuleName ModInfo+ -> Name+ -> ExceptT SDoc m Name+resolveNameFromModule infos name = do+ modL <- maybe (throwE $ "No module for" <+> ppr name) return $+ nameModule_maybe name++ info <- maybe (throwE (ppr (moduleUnit modL) <> ":" <>+ ppr modL)) return $+ M.lookup (moduleName modL) infos++ let all_names = modInfo_rdrs info++ maybe (throwE "No matching export in any local modules.") return $+ 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 ModuleName ModInfo+ -> RealSrcSpan+ -> String+ -> ExceptT SDoc m (ModInfo, Type)+findType infos span0 string = do+ name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+ guessModule infos (srcSpanFilePath span0)++ info <- maybeToExceptT "No module info for current file! Try loading it?" $+ 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 ModuleName ModInfo -> FilePath -> MaybeT m ModuleName+guessModule infos fp = do+ target <- lift $ guessTarget fp Nothing Nothing+ case targetId target of+ TargetModule mn -> return mn+ TargetFile fp' _ -> guessModule' fp'+ where+ guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName+ guessModule' fp' = case findModByFp fp' of+ Just mn -> return mn+ Nothing -> do+ fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++ target' <- lift $ guessTarget fp'' Nothing Nothing+ case targetId target' of+ TargetModule mn -> return mn+ _ -> MaybeT . pure $ findModByFp fp''++ findModByFp :: FilePath -> Maybe ModuleName+ findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+ where+ mifp :: (ModuleName, ModInfo) -> Maybe FilePath+ mifp = ml_hs_file . ms_location . modinfoSummary . snd+++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]+ -> m (Map ModuleName 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) => ModuleName -> m ModInfo+getModInfo name = do+ m <- getModSummary name+ p <- parseModule m+ typechecked <- typecheckModule p+ let allTypes = processAllTypeCheckedModule typechecked+ module_info = tm_checked_module_info typechecked+ !rdr_env = case modInfoRdrEnv module_info of+ Just rdrs -> Strict.Just rdrs+ -- NB: this has already been deeply forced; no need to do that again.+ -- See test case T15369 and Note [Forcing GREInfo] in GHC.Types.GREInfo.+ Nothing -> Strict.Nothing+ ts <- liftIO $ getModificationTime $ srcFilePath m+ return $+ ModInfo+ { modinfoSummary = m+ , modinfoSpans = allTypes+ , modinfoRdrEnv = rdr_env+ , modinfoLastUpdate = ts+ }++-- | Get the 'Name's from the 'GlobalRdrEnv' of the 'ModInfo', if any.+modInfo_rdrs :: ModInfo -> [Name]+modInfo_rdrs mi =+ case modinfoRdrEnv mi of+ Strict.Nothing -> []+ Strict.Just env -> map greName $ globalRdrEnvElts env++-- | 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 (HsWrap _ 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.10.2/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,575 @@+{-# LANGUAGE FlexibleInstances, DeriveFunctor, DerivingVia #-}+{-# 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,++ printForUserNeverQualify,+ printForUserModInfo, printForUserGlobalRdrEnv,+ printForUser, printForUserPartWay, 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.Types.Name.Reader+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 qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx)+import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)+import GHC.Runtime.Interpreter+import GHC.Runtime.Context+import GHCi.RemoteTypes+import Clash.GHCi.UI.Exception (printGhciException)+import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import GHC.Hs.Utils+import GHC.Utils.Misc+import GHC.Utils.Logger++import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)+import Numeric+import Data.Array+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++-----------------------------------------------------------------------------+-- 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,+ multiMode :: Bool,+ 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.+ 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)++ short_help :: String,+ -- ^ help text to display to a user+ long_help :: String,+ lastErrorLocations :: IORef [(FastString, Int)],++ mod_infos :: !(Map ModuleName ModInfo),++ flushStdHandles :: ForeignHValue,+ -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+ noBuffering :: ForeignHValue,+ -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+ ifaceCache :: ModIfaceCache+ }++type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]++-- | 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 } = throwM e+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+ { breakModule :: !GHC.Module+ , breakLoc :: !SrcSpan+ , breakTick :: {-# UNPACK #-} !Int+ , breakEnabled:: !Bool+ , onBreakCmd :: String+ }++instance Eq BreakLocation where+ loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+ breakTick loc1 == breakTick 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 $ breakModule 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) })++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+ dflags <- GHC.getInteractiveDynFlags+ liftIO $ Ppr.printForUser dflags stdout neverQualify AllTheWay doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info = printForUserGlobalRdrEnv (GHC.modInfoRdrEnv info)++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.printForUser 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++-- | 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 => (SrcSpan -> Bool) -> GHC.SingleStep -> Maybe Int -> m GHC.ExecResult+resume canLogSpan step mbIgnoreCnt = do+ st <- getGHCiState+ reifyGHCi $ \x ->+ withProgName (progname st) $+ withArgs (args st) $+ reflectGHCi x $ do+ GHC.resumeExec canLogSpan 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.10.2/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.10.2/Clash/Main.hs view
@@ -0,0 +1,1240 @@+{-# 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+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, compileFile )+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.Ways+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.Env+import GHC.Unit (UnitId, homeUnitDepends)+import GHC.Unit.Home.ModInfo (emptyHomePackageTable)+import GHC.Unit.Module ( ModuleName, mkModuleName )+import GHC.Unit.Module.ModIface+import GHC.Unit.State ( pprUnits, pprUnitsSimple )+import GHC.Unit.Finder ( findImportedModule, FindResult(..) )+import qualified GHC.Unit.State as State+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.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Monad ( liftIO, mapMaybeM )+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.SysTools.BaseDir++import GHC.Iface.Load+import GHC.Iface.Recomp.Binary ( fingerprintBinMem )++import GHC.Tc.Utils.Monad ( initIfaceCheck )+import GHC.Iface.Errors.Ppr++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except (throwE, runExceptT)+import Data.Char+import Data.List ( partition, intercalate, (\\) )+import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Maybe+import Prelude+import GHC.ResponseFile (expandResponse)+import Data.Bifunctor+import GHC.Data.Graph.Directed+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 GHC.Data.EnumSet as EnumSet+import 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 ->+ -- start our GHC session+ 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+ (dflags3, fileish_args, dynamicFlagWarnings) <-+ GHC.parseDynamicFlags logger2 dflags2 args'++ -- Propagate -Werror to Clash+ liftIO . modifyIORef' clashOpts $ \opts ->+ opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }++ let dflags4 = if backendNeedsFullWays bcknd &&+ not (gopt Opt_ExternalInterpreter dflags3)+ then+ let platform = targetPlatform dflags3+ dflags3a = dflags3 { targetWays_ = hostFullWays }+ dflags3b = foldl gopt_set dflags3a+ $ concatMap (wayGeneralFlags platform)+ hostFullWays+ dflags3c = foldl gopt_unset dflags3b+ $ concatMap (wayUnsetGeneralFlags platform)+ hostFullWays+ in dflags3c+ else+ dflags3++ 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++ -- 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+ Nothing -> do+ case srcs of+ [] -> return []+ _ -> do+ s <- initMake srcs+ return $ map (uncurry (,Nothing,)) s+ interactiveUI (defaultGhciSettings clashOpts) hs_srcs maybe_expr+#endif+++-- -----------------------------------------------------------------------------+-- 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)+ && isInterpretiveMode mode+ && 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.)"))++-----------------------------------------------------------------------------+-- 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"++-- ----------------------------------------------------------------------------+-- 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+ 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))++initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)]+initMake srcs = do+ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++ hsc_env <- GHC.getSession++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot hsc_env NoStop srcs) >> return []+ else do++ o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x)+ non_hs_srcs+ dflags <- GHC.getSessionDynFlags+ let dflags' = dflags { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags }+ _ <- GHC.setSessionDynFlags dflags'+ return hs_srcs++-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.+removeRTS :: [String] -> [String]+removeRTS ("+RTS" : xs) =+ case dropWhile (/= "-RTS") xs of+ [] -> []+ (_ : ys) -> removeRTS ys+removeRTS (y:ys) = y : removeRTS ys+removeRTS [] = []++initMulti :: NE.NonEmpty String -> Ghc ([(String, Maybe UnitId, Maybe Phase)])+initMulti unitArgsFiles = do+ hsc_env <- GHC.getSession+ let logger = hsc_logger hsc_env+ initial_dflags <- GHC.getSessionDynFlags++ dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do+ when (verbosity initial_dflags > 2) (liftIO $ print f)+ args <- liftIO $ expandResponse [f]+ (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine initial_dflags (map (mkGeneralLocated f) (removeRTS args))+ handleSourceError (\e -> do+ GHC.printException e+ liftIO $ exitWith (ExitFailure 1)) $ do+ liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)++ let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)+ dflags4 = offsetDynFlags dflags3++ let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++ -- This is dubious as the whole unit environment won't be set-up correctly, but+ -- that doesn't matter for what we use it for (linking and oneShot)+ let dubious_hsc_env = hscSetFlags dflags4 hsc_env+ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, [])+ else do++ o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x)+ non_hs_srcs+ let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files+ ++ ldInputs dflags4 }++ liftIO $ checkOptions DoMake dflags5 srcs objs []++ pure (dflags5, hs_srcs)++ let+ unitDflags = NE.map fst dynFlagsAndSrcs+ srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs+ (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs))++ checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))++ let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags+ home_units = unitEnv_keys initial_home_graph++ home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+ hue_flags = homeUnitEnv_dflags homeUnitEnv+ dflags = homeUnitEnv_dflags homeUnitEnv+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units++ updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants+ pure $ HomeUnitEnv+ { homeUnitEnv_units = unit_state+ , homeUnitEnv_unit_dbs = Just dbs+ , homeUnitEnv_dflags = updated_dflags+ , homeUnitEnv_hpt = emptyHomePackageTable+ , homeUnitEnv_home_unit = Just home_unit+ }++ checkUnitCycles initial_dflags home_unit_graph++ let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph+ unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }++ GHC.setSession final_hsc_env++ -- if we have no haskell sources from which to do a dependency+ -- analysis, then just do one-shot compilation and/or linking.+ -- This means that "ghc Foo.o Bar.o -o baz" links the program as+ -- we expect.+ if (null hs_srcs)+ then do+ liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."+ liftIO $ exitWith (ExitFailure 1)+ else do++{-+ o_files <- liftIO $ mapMaybeM+ (\(src, uid, mphase) ->+ compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)+ )+ (concat non_hs_srcs)+ -}++ -- MP: This should probably modify dflags for each unit?+ --let dflags' = dflags { ldInputs = map (FileOption "") o_files+ -- ++ ldInputs dflags }+ return $ concat hs_srcs++-- | Check that we don't have multiple units with the same UnitId.++checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc ()+checkUnitCycles dflags graph = processSCCs sccs+ where+ mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId+ mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue))+ nodes = map mkNode (unitEnv_elts graph)++ sccs = stronglyConnCompFromEdgedVerticesOrd nodes++ processSCCs [] = return ()+ processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs+ processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)+++ cycle_err uids =+ hang (text "Units form a dependency cycle:")+ 2+ (one_err uids)++ one_err uids = vcat $+ (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)+ ++ [text "-" <+> ppr final]+ where+ start = init uids+ final = last uids++checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()+checkDuplicateUnits dflags flags =+ unless (null duplicate_ids)+ (throwGhcException $ CmdLineError $ showSDoc dflags multi_err)++ where+ uids = map (second homeUnitId_) flags+ deduplicated_uids = ordNubOn snd uids+ duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids)++ duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids++ one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp++ multi_err =+ hang (text "Multiple units with the same unit-id:")+ 2+ (vcat (map one_err duplicate_flags))+++offsetDynFlags :: DynFlags -> DynFlags+offsetDynFlags dflags =+ dflags { hiDir = c hiDir+ , objectDir = c objectDir+ , stubDir = c stubDir+ , hieDir = c hieDir+ , dumpDir = c dumpDir }++ where+ c f = augment_maybe (f dflags)++ augment_maybe Nothing = Nothing+ augment_maybe (Just f) = Just (augment f)+ augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f+ | otherwise = f+++createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> (HomeUnitGraph, UnitId)+createUnitEnvFromFlags unitDflags =+ let+ newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing+ unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags+ activeUnit = fst $ NE.head unitEnvList+ in+ (unitEnv_new (Map.fromList (NE.toList (unitEnvList))), activeUnit)++-- ---------------------------------------------------------------------------+-- 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 Paths_clash_ghc.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++ 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 . mi_final_exts) ifaces+ f <- fingerprintBinMem bh++ putStrLn (showPpr dflags f)++-----------------------------------------------------------------------------+-- HDL Generation++makeHDL'+ :: forall backend+ . Clash.Backend.Backend backend+ => Proxy backend+ -> Ghc ()+ -> IORef ClashOpts+ -> [(String,Maybe Phase)]+ -> Ghc ()+makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")+makeHDL' proxy startAction r srcs = makeHDL proxy startAction r $ fmap 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)++-- -----------------------------------------------------------------------------+-- Util++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.10/Clash/GHCi/Leak.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE RecordWildCards, LambdaCase #-}-module Clash.GHCi.Leak- ( LeakIndicators- , getLeakIndicators- , checkLeakIndicators- ) where--import Control.Monad-import Data.Bits-import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)-import GHC-import GHC.Ptr (Ptr (..))-import Clash.GHCi.Util-import GHC.Driver.Env-import GHC.Driver.Ppr-import GHC.Utils.Outputable-import GHC.Unit.Module.ModDetails-import GHC.Unit.Home.ModInfo-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 $- forM (eltsUDFM (hsc_HPT hsc_env)) $ \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.10/Clash/GHCi/UI.hs
@@ -1,4883 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}--{-# 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-import GHC.Runtime.Debugger---- The GHC interface-import GHC.Runtime.Interpreter-import GHCi.RemoteTypes-import GHCi.BreakArray( breakOn, breakOff )-import GHC.ByteCode.Types-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 )-import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) )-import GHC.Driver.Config.Parser (initParserOpts)-import GHC.Driver.Config.Diagnostic-import qualified GHC-import GHC ( LoadHowMuch(..), Target(..), TargetId(..),- Resume, SingleStep, Ghc,- GetDocsFailure(..), pushLogHookM,- getModuleGraph, handleSourceError, ms_mod )-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 )-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 ( orElse, expectJust )-import GHC.Types.Name.Set-import GHC.Utils.Panic hiding ( showException, try )-import GHC.Utils.Misc-import qualified GHC.LanguageExtensions as LangExt-import GHC.Data.Bag (unitBag)-import qualified GHC.Data.Strict as Strict-import GHC.Types.Error---- 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 Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )-import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy,- 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.ModInfo--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 Clash.GHCi.Leak-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.Util (clashLibVersion, reportTimeDiff)-import Data.Proxy-import qualified Data.Time.Clock as Clock-import qualified Paths_clash_ghc---------------------------------------------------------------------------------data GhciSettings = GhciSettings {- availableCommands :: [Command],- shortHelpText :: String,- fullHelpText :: String,- defPrompt :: PromptFunction,- defPromptCont :: PromptFunction- }--defaultGhciSettings :: IORef ClashOpts -> GhciSettings-defaultGhciSettings opts =- GhciSettings {- availableCommands = ghciCommands opts,- shortHelpText = defShortHelpText,- 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", keepGoingMulti' changeDirectory, completeFilename),- ("check", keepGoing' checkModule, completeHomeModule),- ("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", keepGoingMulti' editFile, completeFilename),- ("enable", keepGoing enableCmd, noCompletion),- ("force", keepGoing forceCmd, completeExpression),- ("forward", keepGoing forwardCmd, noCompletion),- ("help", keepGoingMulti help, noCompletion),- ("history", keepGoingMulti historyCmd, noCompletion),- ("info", keepGoingMulti' (info False), completeIdentifier),- ("info!", keepGoingMulti' (info True), completeIdentifier),- ("issafe", keepGoing' isSafeCmd, completeModule),- ("ignore", keepGoing ignoreCmd, noCompletion),- ("kind", keepGoingMulti' (kindOfType False), completeIdentifier),- ("kind!", keepGoingMulti' (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", keepGoingMulti' reloadModule, noCompletion),- ("reload!", keepGoingMulti' reloadModuleDefer, noCompletion),- ("run", keepGoing runRun, completeFilename),- ("script", keepGoing' scriptCmd, completeFilename),- ("set", keepGoingMulti setCmd, completeSetOptions),- ("seti", keepGoingMulti setiCmd, completeSeti),- ("show", keepGoingMulti' showCmd, completeShowOptions),- ("showi", keepGoing showiCmd, completeShowiOptions),- ("sprint", keepGoing sprintCmd, completeExpression),- ("step", keepGoing stepCmd, completeIdentifier),- ("steplocal", keepGoing stepLocalCmd, completeIdentifier),- ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),- ("type", keepGoingMulti' 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--keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)-keepGoingMulti a str = keepGoingMulti' (lift . a) str--keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome-keepGoing' a str = do- in_multi <- inMultiMode- if in_multi- then- liftIO $ hPutStrLn stderr "Command is not supported (yet) in multi-mode"- else- a str- return CmdSuccess---- For commands which are actually support in multi-mode, initially just :reload-keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m CmdExecOutcome-keepGoingMulti' a str = a str >> return CmdSuccess--inMultiMode :: GhciMonad m => m Bool-inMultiMode = multiMode <$> getGHCiState--keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)-keepGoingPaths a str- = do case toArgsNoLoc str of- Left err -> liftIO $ hPutStrLn stderr err >> return CmdSuccess- Right args -> keepGoing' a args--defShortHelpText :: String-defShortHelpText = "use :? for help.\n"--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"++- " :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- -- This is a HACK to make sure dynflags are not overwritten when setting- -- options. When GHCi is made properly multi component it should be removed.- modifySession (\env -> hscSetActiveUnitId (hscActiveUnitId env) env)- -- 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-- -- 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 dflags' = (xopt_set_unlessExplSpec- LangExt.ExtendedDefaultRules xopt_set)- . (xopt_set_unlessExplSpec- LangExt.MonomorphismRestriction xopt_unset)- $ dflags- GHC.setInteractiveDynFlags dflags'- _ <- GHC.setProgramDynFlags- -- Set Opt_KeepGoing so that :reload loads as much as- -- possible- (gopt_set dflags Opt_KeepGoing)-- -- 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}}- hsc_env <- GHC.getSession- let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1- 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 = [],- multiMode = in_multi,- 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,- 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,- short_help = shortHelpText config,- long_help = fullHelpText config,- lastErrorLocations = lastErrLocationsRef,- mod_infos = M.empty,- flushStdHandles = flush,- noBuffering = nobuffering,- ifaceCache = empty_cache- }-- return ()--{--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.--- Uses ~/.ghc (getAppUserDataDirectory) if it exists--- If it doesn't, then it uses $XDG_DATA_HOME/ghc--- Earlier we always used to use ~/.ghc, but we want--- to gradually move to $XDG_DATA_HOME to respect the XDG specification------ As a migration strategy, we will only create new directories in--- the appropriate XDG location. However, we will use the old directory--- if it already exists.-getAppDataFile :: FilePath -> IO (Maybe FilePath)-getAppDataFile file = do- let new_path = tryIO (getXdgDirectory XdgConfig "clash") >>= \case- Left _ -> pure Nothing- Right dir -> flip catchIO (const $ return Nothing) $ do- createDirectoryIfMissing False dir- pure $ Just $ dir </> file-- e_old_path <- tryIO (getAppUserDataDirectory "clash")- case e_old_path of- Right old_path -> doesDirectoryExist old_path >>= \case- True -> pure $ Just $ old_path </> file- False -> new_path- Left _ -> new_path--runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi ()-runGHCi paths maybe_exprs = do- dflags <- getDynFlags- let- ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags-- app_user_dir = liftIO $ getAppDataFile "clashi.conf"-- home_dir = do- either_dir <- liftIO $ tryIO (getEnv "HOME")- case either_dir of- Right home -> return (Just (home </> ".clashi"))- _ -> return 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 [ app_user_dir, home_dir ]- 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 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- -- Set different defaulting rules (See #280)- 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) -> return (Just (currentDirectory </> ".clashi_history"))- (True, _) -> liftIO $ getAppDataFile "clashi_history"- _ -> return 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 d | Just m <- ideclAs d = unLoc m- | otherwise = unLoc (ideclName d)-- modules_names =- ['*':(moduleNameString 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 <- liftIO $ do- (code, out, err) <-- readProcessWithExitCode- cmd args ""- `catchIO` \e -> return (ExitFailure 1, "", show e)- case code of- ExitSuccess -> return out- _ -> do- hPutStrLn stderr 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 $- 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-- 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?- 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- pflags <- initParserOpts <$> GHC.getInteractiveDynFlags- -- 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 find.- set_pragmas pflags-- 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 =- let stringbuf = stringToStringBuffer input- (_msgs, loc_opts) = Header.getOptions pflags 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 (const True) 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 (const True) (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 (unitBag (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- => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult-afterRunStmt step_here 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- , isNothing mb_info ||- step_here (GHC.resumeSpan first_resume) -> 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_here GHC.SingleStep Nothing >>=- afterRunStmt step_here >> 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.BreakInfo -> m (Maybe (Int, BreakLocation))-toBreakIdAndLocation Nothing = return Nothing-toBreakIdAndLocation (Just inf) = do- let md = GHC.breakInfo_module inf- nm = GHC.breakInfo_number inf- st <- getGHCiState- return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),- breakModule loc == md,- breakTick loc == nm ]--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- htxt <- short_help <$> getGHCiState- case maybe_cmd of- GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)- BadCommand ->- do liftIO $ hPutStr stderr ("unknown command ':" ++ cmd ++ "'\n"- ++ htxt)- return CmdFailure- NoLastCommand ->- do liftIO $ hPutStr stderr ("there is no last command to perform\n"- ++ htxt)- 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)--getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)-getCurrentBreakSpan = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (Just (GHC.resumeSpan r))- else do- let hist = GHC.resumeHistory r !! (ix-1)- pan <- GHC.getHistorySpan hist- return (Just pan)--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))--getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)-getCurrentBreakModule = do- resumes <- GHC.getResumeContext- case resumes of- [] -> return Nothing- (r:_) -> do- let ix = GHC.resumeHistoryIx r- if ix == 0- then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)- else do- let hist = GHC.resumeHistory r !! (ix-1)- return $ Just $ GHC.getHistoryModule hist------------------------------------------------------------------------------------- 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 :: GHC.GhcMonad m => Bool -> String -> m ()-info _ "" = throwGhcException (CmdLineError "syntax: ':i <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 = case toArgsNoLoc s of- Left err -> liftIO (hPutStrLn stderr err)- Right args -> doWithMain (doWithArgs args)- 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`---------------------------------------------------------------------------------- :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 $ isLoadedModSummary 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.ms_location 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 _ (':':_) = (liftIO $ hPutStrLn stderr- "macro name cannot start with a colon")- >> failIfExprEvalMode-defineMacro _ ('!':_) = (liftIO $ hPutStrLn stderr- "macro name cannot start with an exclamation mark")- >> failIfExprEvalMode- -- little code duplication allows to grep error msg-defineMacro overwrite s = do- let (macro_name, definition) = break isSpace s- macros <- ghci_macros <$> getGHCiState- let defined = map cmdName macros- if null macro_name- then if null defined- then liftIO $ putStrLn "no macros defined"- else liftIO $ putStr ("the following macros are defined:\n" ++- unlines defined)- else do- isCommand <- isJust <$> lookupCommand' macro_name- let check_newname- | macro_name `elem` defined = throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))- | isCommand = throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))- | otherwise = return ()- hint = " Use ':def!' to overwrite."-- unless overwrite check_newname- -- 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 }--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 throwGhcException (CmdLineError- ("macro '" ++ macro_name ++ "' is not defined"))- 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---------------------------------------------------------------------------------- :check--checkModule :: GhciMonad m => String -> m ()-checkModule m = do- let modl = GHC.mkModuleName m- ok <- handleSourceError (\e -> printErrAndMaybeExit e >> return False) $ do- r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl- dflags <- getDynFlags- liftIO $ putStrLn $ showSDoc dflags $- case GHC.moduleInfo r of- cm | Just scope <- GHC.modInfoTopLevelScope cm ->- let- (loc, glob) = assert (all isExternalName scope) $- partition ((== modl) . GHC.moduleName . GHC.nameModule) scope- in- (text "global names: " <+> ppr glob) $$- (text "local names: " <+> ppr loc)- _ -> empty- return True- afterLoad (successIf ok) Check---------------------------------------------------------------------------------- :doc--docCmd :: GHC.GhcMonad m => String -> m ()-docCmd "" =- throwGhcException (CmdLineError "syntax: ':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 "" =- throwGhcException (CmdLineError "syntax: ':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 originalFlags to avoid leaking the associated HscEnv- !originalFlags <- getDynFlags- void $ GHC.setProgramDynFlags $- setGeneralFlag' Opt_DeferTypeErrors originalFlags- return originalFlags)- (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)- (\_ -> load)--loadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag-loadModule fs = do- (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)- either (liftIO . Exception.throwIO) return result---- | @:load@ command-loadModule_ :: GhciMonad m => [FilePath] -> m ()-loadModule_ fs = void $ loadModule (zip3 fs (repeat Nothing) (repeat Nothing))--loadModuleDefer :: GhciMonad m => [FilePath] -> m ()-loadModuleDefer = wrapDeferTypeErrors . loadModule_--loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag-loadModule' 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- doLoadAndCollectInfo Load LoadAllTargets-- 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- targets <- mapM (\m -> GHC.guessTarget m Nothing 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 liftIO $ hPutStrLn stderr ("Module " ++ moduleNameString m ++ " not found")- failIfExprEvalMode- return False-- checkTargetFile :: GhciMonad m => String -> m Bool- checkTargetFile f = do- exists <- liftIO (doesFileExist f)- unless exists $ do- liftIO $ hPutStrLn stderr $ "File " ++ f ++ " not found"- failIfExprEvalMode- return exists---- | @:unadd@ command-unAddModule :: GhciMonad m => [FilePath] -> m ()-unAddModule files = do- files' <- mapM expandPath files- targets <- mapM (\m -> GHC.guessTarget m Nothing 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- session <- GHC.getSession- let home_unit = homeUnitId (hsc_home_unit session)- ok <- doLoadAndCollectInfo Reload (loadTargets home_unit)- when (failed ok) failIfExprEvalMode- where- loadTargets hu | null m = LoadAllTargets- | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m))--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- -- MP: :set +c code path only works in single package mode atm, hence- -- this call to isLoaded is ok. collectInfo needs to be modified further to- -- work with :set +c so I have punted on that for now.- loaded <- filterM GHC.isLoaded (map ms_mod_name 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) (mkUnknownDiagnostic . GHCiMessage) 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) = isLoadedModSummary 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.ms_mod_name summary == m then Just summary else Nothing- (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetFile f _ }- | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) =- if f == f' then Just summary else Nothing- _ `matches` _ = Nothing-- load_this summary | m <- GHC.ms_mod 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 (GHC.moduleName 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 (unLoc $ ideclName d) (ideclPkgQual d)- e <- MC.try $ GHC.findQualifiedModule pkgqual mod_name- case e :: Either SomeException Module of- Left _ -> return False- Right m -> return (not (isMainUnitModule m))- where- mod_name = unLoc (ideclName d)----modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> 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 mod- pure $ if is_interpreted- then ppr (GHC.ms_mod mod)- else ppr (GHC.ms_mod mod)- <+> parens (text $ normalise $ msObjFilePath 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 SDoc m () -> m ()-runExceptGhciMonad act = handleSourceError printGhciException $- either handleErr pure =<<- runExceptT act- where- handleErr sdoc = do- rendered <- showSDocForUserQualify sdoc- liftIO $ hPutStrLn stderr rendered- failIfExprEvalMode---- | 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 top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top- _ -> []- where- go srcs = do- dflags <- GHC.getSessionDynFlags- goX dflags srcs `MC.finally` recover dflags-- goX dflags srcs = do- -- Issue #439 step 1- (dflagsX,_,_) <- parseDynamicFlagsCmdLine 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- 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)] }---------------------------------------------------------------------------------- | @:type-at@ command--typeAtCmd :: GhciMonad m => String -> m ()-typeAtCmd str = runExceptGhciMonad $ do- (span',sample) <- exceptT $ parseSpanArg str- infos <- lift $ mod_infos <$> getGHCiState- (info, ty) <- findType infos span' sample- let mb_rdr_env = case modinfoRdrEnv info of- Strict.Just rdrs -> Just rdrs- Strict.Nothing -> Nothing- 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 <- 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) <- 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 SDoc (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 SDoc (Int,String)- readAsInt "" = Left "Premature end of string while expecting Int"- readAsInt s0 = case reads s0 of- [s_rest] -> Right s_rest- _ -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")-- readAsString :: String -> Either SDoc (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 = Left ("Couldn't read" <+> text (show s0) <+> "as String")-- skipWs1 :: String -> Either SDoc String- skipWs1 (c:cs) | isWs c = Right (skipWs cs)- skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))-- isWs = (`elem` [' ','\t'])- skipWs = dropWhile isWs- breakWs = break isWs----- | 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- _ -> throwGhcException (CmdLineError "syntax: :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 :: GHC.GhcMonad m => String -> m ()-isSafeCmd m =- case words m of- [s] | looksLikeModuleName s -> do- md <- lookupModule s- isSafeModule md- [] -> do md <- guessCurrentModule "issafe"- isSafeModule md- _ -> throwGhcException (CmdLineError "syntax: :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 : _ -> GHC.findQualifiedModule NoPkgQual 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- let names- | exports_only = GHC.modInfoExports mod_info- | otherwise = GHC.modInfoTopLevelScope mod_info- `orElse` []-- -- 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 = throwGhcException (CmdLineError "syntax: :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- mapM_ addII (map mkIIModule starred ++ 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 modname- | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"- | otherwise -> wantInterpretedModuleName modname >> return ()-- IIDecl d -> do- let modname = unLoc (ideclName d)- pkgqual <- GHC.renameRawPkgQualM modname (ideclPkgQual d)- m <- GHC.lookupQualifiedModule pkgqual modname- when safe $ do- t <- GHC.isModuleTrusted m- when (not 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 []-- return prel_iidecls---- -------------------------------------------------------------------------------- Utils on InteractiveImport--mkIIModule :: ModuleName -> InteractiveImport-mkIIModule = IIModule--mkIIDecl :: ModuleName -> InteractiveImport-mkIIDecl = IIDecl . simpleImportDecl--iiModules :: [InteractiveImport] -> [ModuleName]-iiModules is = [m | IIModule m <- is]--isIIModule :: InteractiveImport -> Bool-isIIModule (IIModule _) = True-isIIModule _ = False--iiModuleName :: InteractiveImport -> ModuleName-iiModuleName (IIModule m) = 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- && (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) ->- case toArgsNoLoc rest of- Left err -> liftIO (hPutStrLn stderr err)- Right args -> setArgs args- Right ("prog", rest) ->- case toArgsNoLoc rest of- Right [prog] -> setProg prog- _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")-- Right ("prompt", rest) ->- setPromptString setPrompt (dropWhile isSpace rest)- "syntax: set prompt <string>"- Right ("prompt-function", rest) ->- setPromptFunc setPrompt $ dropWhile isSpace rest- Right ("prompt-cont", rest) ->- setPromptString setPromptCont (dropWhile isSpace rest)- "syntax: :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- _ -> case toArgsNoLoc str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> () <$ keepGoing' setOptions wds--setiCmd :: GhciMonad m => String -> m ()-setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False-setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True-setiCmd str =- case toArgsNoLoc str of- Left err -> liftIO (hPutStrLn stderr err)- Right wds -> newDynFlags True wds--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)- ))- liftIO $ showDynFlags show_all dflags---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 = throwGhcException- (CmdLineError "syntax: :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 :: MonadIO m- => (PromptFunction -> m ()) -> String -> String -> m ()-setPromptString fSetPrompt value err = do- if null value- then liftIO $ hPutStrLn stderr $ err- else case value of- ('\"':_) ->- case reads value of- [(value', xs)] | all isSpace xs ->- setParsedPromptString fSetPrompt value'- _ -> liftIO $ hPutStrLn stderr- "Can't parse prompt string. Use Haskell syntax."- _ ->- 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---- | newDynFlags 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)-newDynFlags :: GhciMonad m => Bool -> [String] -> m ()-newDynFlags interactive_only minus_opts = do- let lopts = map noLoc minus_opts-- logger <- getLogger- idflags0 <- GHC.getInteractiveDynFlags- (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts-- liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)- when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)-- when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do- liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"- GHC.setInteractiveDynFlags idflags1- installInteractivePrint (interactivePrint idflags1) False-- dflags0 <- getDynFlags-- when (not interactive_only) $ do- (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine dflags0 lopts- must_reload <- GHC.setProgramDynFlags dflags1-- -- if the package flags changed, reset the context and link- -- the new packages.- hsc_env <- GHC.getSession- let dflags2 = hsc_dflags hsc_env- let interp = hscInterp hsc_env- when (packageFlagsChanged dflags2 dflags0) $ do- when (verbosity dflags2 > 0) $- liftIO . putStrLn $- "package flags have changed, resetting and loading new packages..."- -- Clear caches and eventually defined breakpoints. (#1620)- clearCaches- when must_reload $ do- let units = preloadUnits (hsc_units hsc_env)- liftIO $ Loader.loadPackages interp hsc_env units- -- package flags changed, we can't re-use any of the old context- setContextAfterLoad False Nothing- -- and copy the package flags to the interactive DynFlags- idflags <- GHC.getInteractiveDynFlags- GHC.setInteractiveDynFlags- idflags{ packageFlags = packageFlags dflags2 }-- let ld0length = length $ ldInputs dflags0- fmrk0length = length $ cmdlineFrameworks dflags0-- newLdInputs = drop ld0length (ldInputs dflags2)- newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)-- dflags' = dflags2 { ldInputs = newLdInputs- , cmdlineFrameworks = newCLFrameworks- }- hsc_env' = hscSetFlags dflags' hsc_env-- when (not (null newLdInputs && null newCLFrameworks)) $- liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'-- return ()--unknownFlagsErr :: [String] -> a-unknownFlagsErr fs = throwGhcException $ CmdLineError $ concatMap oneError fs- where- oneError f =- "unrecognised flag: " ++ f ++ "\n" ++- (case flagSuggestions ghciFlags f of- [] -> ""- suggs -> "did you mean one of:\n" ++ unlines (map (" " ++) suggs))- ghciFlags = nubSort $ flagsForCompletion True--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- dflags <- getDynFlags- 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-- _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]- in throwGhcException $ CmdLineError $ showSDoc dflags- $ hang (text "syntax:") 4- $ hang (text ":show") 6- $ brackets (fsep $ punctuate (text " |") helpCmds)--showiCmd :: GHC.GhcMonad m => String -> m ()-showiCmd str = do- case words str of- ["languages"] -> showiLanguages -- backwards compat- ["language"] -> showiLanguages- ["lang"] -> showiLanguages -- useful abbreviation- _ -> throwGhcException (CmdLineError ("syntax: :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 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.ModSummary]-getLoadedModules = do- graph <- GHC.getModuleGraph- filterM isLoadedModSummary (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)--isLoadedModSummary :: GHC.GhcMonad m => ModSummary -> m Bool-isLoadedModSummary ms = GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms)--{--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- printForUser $ vcat (map pp_resume (reverse resumes))- where- pp_resume res =- text "--> " <> text (GHC.resumeStmt res)- $$ nest 2 (pprStopped res)--pprStopped :: GHC.Resume -> SDoc-pprStopped res =- 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)- where- mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res--showUnits :: GHC.GhcMonad m => m ()-showUnits = do- dflags <- getDynFlags- 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 = do- dflags <- getDynFlags- 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 = getDynFlags >>= 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- _ -> throwGhcException (CmdLineError "Syntax: :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,- completeHomeModule, 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 => [ModuleName] -> Module -> m [String]- bidsByModule nonquals mod = do- (_, decls) <- getModBreak mod- let bids = nub $ declPath <$> elems decls- pure $ case (moduleName 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- (_, decls) <- getModBreak mod- 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.ms_mod_name) 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.ms_mod_name) getLoadedModules- return $ loaded_mods ++ pkg_mods- return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules--completeHomeModule = wrapIdentCompleterMod listHomeModules--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 (const True) GHC.SingleStep- step expression = runStmt expression GHC.SingleStep >> return ()--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 <- enclosingTickSpan md loc- doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Strict.Nothing) GHC.SingleStep--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 -> do- let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span- doContinue f GHC.SingleStep---- | Returns the span of the largest tick containing the srcspan given-enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan-enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"-enclosingTickSpan md (RealSrcSpan src _) = do- ticks <- getTickArray md- let line = srcSpanStartLine src- massert (inRange (bounds ticks) line)- let enclosing_spans = [ pan | (_,pan) <- ticks ! line- , realSrcSpanEnd pan >= realSrcSpanEnd src]- return . minimumBy leftmostLargestRealSrcSpan $ enclosing_spans- where--leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering-leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd--traceCmd :: GhciMonad m => String -> m ()-traceCmd arg- = withSandboxOnly ":trace" $ tr arg- where- tr [] = doContinue (const True) 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' (const True) 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 => (SrcSpan -> Bool) -> SingleStep -> m ()-doContinue pre step = doContinue' pre step Nothing--doContinue' :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ()-doContinue' pre step mbCnt= do- runResult <- resume pre step mbCnt- _ <- afterRunStmt pre 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- let breakInfo = GHC.BreakInfo (breakModule loc) (breakTick loc)- setupBreakpoint breakInfo 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.BreakInfo -> Int -> m()-setupBreakpoint loc count = do- hsc_env <- GHC.getSession- GHC.setupBreakpoint hsc_env loc 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- (mn : _) -> do- md <- lookupModuleName mn- 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 Nothing (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- let (mod_str, top_level, fun_str) = splitIdent inp- mod_top_lvl = combineModIdent mod_str top_level- mb_mod <- catch (lookupModuleInscope mod_top_lvl)- (\(_ :: SomeException) -> lookupModuleInGraph mod_str)- -- If the top-level name is not in scope, `lookupModuleInscope` will- -- throw an exception, then lookup the module name in the module graph.- mb_err_msg <- validateBP mod_str fun_str mb_mod- case mb_err_msg of- Just err_msg -> printForUser $- text "Cannot set breakpoint on" <+> quotes (text inp)- <> text ":" <+> err_msg- Nothing -> do- -- No errors found, go and set the breakpoint- mb_mod_info <- GHC.getModuleInfo $ fromJust mb_mod- let modBreaks = case mb_mod_info of- (Just mod_info) -> GHC.modInfoModBreaks mod_info- Nothing -> emptyModBreaks- findBreakAndSet (fromJust mb_mod) $ findBreakForBind fun_str modBreaks- where- -- Try to lookup the module for an identifier that is in scope.- -- `parseName` throws an exception, if the identifier is not in scope- lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)- lookupModuleInscope mod_top_lvl = do- names <- GHC.parseName mod_top_lvl- pure $ Just $ NE.head $ GHC.nameModule <$> names-- -- Lookup the Module of a module name in the module graph- lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)- lookupModuleInGraph mod_str = do- graph <- GHC.getModuleGraph- let hmods = ms_mod <$> GHC.mgModSummaries graph- pure $ find ((== mod_str) . showModule) hmods-- -- Check validity of an identifier to set a breakpoint:- -- 1. The module of the identifier must exist- -- 2. the identifier must be in an interpreted module- -- 3. the ModBreaks array for module `mod` must have an entry- -- for the function- validateBP :: GhciMonad m => String -> String -> Maybe Module- -> m (Maybe SDoc)- validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text- (combineModIdent mod_str (Prelude.takeWhile (/= '.') fun_str)))- <+> text "not in scope"- validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing"- validateBP _ fun_str (Just modl) = do- isInterpr <- GHC.moduleIsInterpreted modl- (_, decls) <- getModBreak modl- mb_err_msg <- case isInterpr of- False -> pure $ Just $ text "Module" <+> quotes (ppr modl)- <+> text "is not interpreted"- True -> case fun_str `elem` (declPath <$> elems decls) of- False -> pure $ Just $- text "No breakpoint found for" <+> quotes (text fun_str)- <+> "in module" <+> quotes (ppr modl)- True -> pure Nothing- pure mb_err_msg--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- setBreakFlag md tick True- (alreadySet, nm) <-- recordBreak $ BreakLocation- { breakModule = md- , breakLoc = RealSrcSpan pan Strict.Nothing- , breakTick = tick- , onBreakCmd = ""- , breakEnabled = True- }- printForUser $- text "Breakpoint " <> ppr nm <>- if alreadySet- then text " was already set at " <> ppr pan- else text " activated at " <> ppr pan---- When a line number is specified, the current policy for choosing--- the best breakpoint is this:--- - the leftmost complete subexpression on the specified line, or--- - the leftmost subexpression starting on the specified line, or--- - the rightmost subexpression enclosing the specified line----findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)-findBreakByLine line arr- | not (inRange (bounds arr) line) = Nothing- | otherwise =- listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus`- listToMaybe (sortBy (compare `on` snd) incomp) `mplus`- listToMaybe (sortBy (flip compare `on` snd) ticks)- where- ticks = arr ! line-- starts_here = [ (ix,pan) | (ix, pan) <- ticks,- GHC.srcSpanStartLine pan == line ]-- (comp, incomp) = partition ends_here starts_here- where ends_here (_,pan) = GHC.srcSpanEndLine pan == line---- The aim is to find the breakpoints for all the RHSs of the--- equations corresponding to a binding. So we find all breakpoints--- for--- (a) this binder only (it maybe a top-level or a nested declaration)--- (b) that do not have an enclosing breakpoint-findBreakForBind :: String -> GHC.ModBreaks -> TickArray- -> [(BreakIndex,RealSrcSpan)]-findBreakForBind str_name modbreaks _ = filter (not . enclosed) ticks- where- ticks = [ (index, span)- | (index, decls) <- assocs (GHC.modBreaks_decls modbreaks),- str_name == declPath decls,- RealSrcSpan span _ <- [GHC.modBreaks_locs modbreaks ! index] ]- enclosed (_,sp0) = any subspan ticks- where subspan (_,sp) = sp /= sp0 &&- realSrcSpanStart sp <= realSrcSpanStart sp0 &&- realSrcSpanEnd sp0 <= realSrcSpanEnd sp--findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray- -> Maybe (BreakIndex,RealSrcSpan)-findBreakByCoord mb_file (line, col) arr- | not (inRange (bounds arr) line) = Nothing- | otherwise =- listToMaybe (sortBy (flip compare `on` snd) contains ++- sortBy (compare `on` snd) after_here)- where- ticks = arr ! line-- -- the ticks that span this coordinate- contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col),- is_correct_file pan ]-- is_correct_file pan- | Just f <- mb_file = GHC.srcSpanFile pan == f- | otherwise = True-- after_here = [ tick | tick@(_,pan) <- ticks,- GHC.srcSpanStartLine pan == line,- GHC.srcSpanStartCol pan >= col ]---- 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- md <- lookupModuleName mn- listModuleLine md (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 (Just (GHC.srcLocFile l))- (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- Nothing -> panic "listModuleLine"- Just summ -> do- let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))- loc = mkRealSrcLoc (mkFastString (filename)) line 0- listAround (realSrcLocSpan loc) False---- | 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- (ticks, _) <- getModBreak modl- let arr = mkTickArray (assocs ticks)- setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}- return arr--discardTickArrays :: GhciMonad m => m ()-discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})--mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray-mkTickArray ticks- = accumArray (flip (:)) [] (1, max_line)- [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ]- where- max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ]- srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ]---- 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 = hme { homeUnitEnv_hpt = emptyHomePackageTable }- discardMG hsc = hsc { hsc_mod_graph = GHC.emptyMG }- modifySession (discardMG . discardIC . hscUpdateHUG (unitEnv_map pruneHomeUnitEnv))----- 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 (breakModule loc) (breakTick loc) onOff- return loc { breakEnabled = onOff }--getModBreak :: GHC.GhcMonad m- => Module -> m (Array Int SrcSpan, Array Int [String])-getModBreak m = do- mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m- let modBreaks = GHC.modInfoModBreaks mod_info- let ticks = GHC.modBreaks_locs modBreaks- let decls = GHC.modBreaks_decls modBreaks- return (ticks, decls)--setBreakFlag :: GhciMonad m => Module -> Int -> Bool ->m ()-setBreakFlag md ix enaDisa = do- let enaDisaToCount True = breakOn- enaDisaToCount False = breakOff- setupBreakpoint (GHC.BreakInfo md ix) $ enaDisaToCount enaDisa---- ------------------------------------------------------------------------------ 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 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 = (>> failIfExprEvalMode) . printGhciException---------------------------------------------------------------------------------- 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 = GHC.lookupQualifiedModule NoPkgQual mName--isMainUnitModule :: Module -> Bool-isMainUnitModule m = GHC.moduleUnit m == mainUnit--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- let str = moduleNameString modname- home_unit <- hsc_home_unit <$> GHC.getSession- unless (isHomeModule home_unit modl) $- 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------ Split up a string with an eventually qualified declaration name into 3 components--- 1. module name--- 2. top-level decl--- 3. full-name of the eventually nested decl, but without module qualification--- eg "foo" = ("", "foo", "foo")--- "A.B.C.foo" = ("A.B.C", "foo", "foo")--- "M.N.foo.bar" = ("M.N", "foo", "foo.bar")-splitIdent :: String -> (String, String, String)-splitIdent [] = ("", "", "")-splitIdent inp@(a : _)- | (isUpper a) = case fixs of- [] -> (inp, "", "")- (i1 : [] ) -> (upto i1, from i1, from i1)- (i1 : i2 : _) -> (upto i1, take (i2 - i1 - 1) (from i1), from i1)- | otherwise = case ixs of- [] -> ("", inp, inp)- (i1 : _) -> ("", upto i1, inp)- where- ixs = elemIndices '.' inp -- indices of '.' in whole input- fixs = dropWhile isNextUc ixs -- indices of '.' in function names --- isNextUc ix = isUpper $ safeInp !! (ix+1)- safeInp = inp ++ " "- upto i = take i inp- from i = drop (i + 1) inp---- Qualify an identifier name with a module name--- combineModIdent "A" "foo" = "A.foo"--- combineModIdent "" "foo" = "foo"-combineModIdent :: String -> String -> String-combineModIdent mod ident- | null mod = ident- | null ident = mod- | otherwise = mod ++ "." ++ ident
− src-bin-9.10/Clash/GHCi/UI/Exception.hs
@@ -1,142 +0,0 @@-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}-module Clash.GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where--import GHC.Prelude--import GHC.Driver.Config.Diagnostic-import GHC.Driver.Errors-import GHC.Driver.Errors.Types-import GHC.Driver.Session--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-import GHC.Types.SourceError--import GHC.Unit.State--import GHC.Utils.Logger-import GHC.Utils.Outputable--import Control.Monad.IO.Class----- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting--- for some error messages.-printGhciException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()-printGhciException err = do- dflags <- getDynFlags- logger <- getLogger- let !diag_opts = initDiagOpts dflags- !print_config = initPrintConfig dflags- liftIO $ printMessages logger print_config diag_opts (GHCiMessage <$> (srcErrorMessages err))---newtype GHCiMessage = GHCiMessage { _getGhciMessage :: GhcMessage }--instance Diagnostic GHCiMessage where- type DiagnosticOpts GHCiMessage = DiagnosticOpts GhcMessage-- diagnosticMessage opts (GHCiMessage msg) = ghciDiagnosticMessage opts msg-- diagnosticReason (GHCiMessage msg) = diagnosticReason msg-- diagnosticHints (GHCiMessage msg) = ghciDiagnosticHints msg-- diagnosticCode (GHCiMessage msg) = diagnosticCode msg----- | 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.)"
− src-bin-9.10/Clash/GHCi/UI/Info.hs
@@ -1,409 +0,0 @@-{-# 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.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---- | 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 :: !(Strict.Maybe 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 ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m (ModInfo,Name,SrcSpan)-findLoc infos span0 string = do- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $- guessModule infos (srcSpanFilePath span0)-- info <- maybeToExceptT "No module info for current file! Try loading it?" $- MaybeT $ pure $ M.lookup name infos-- name' <- findName infos span0 info string-- case getSrcSpan name' of- UnhelpfulSpan{} -> do- throwE ("Found a name, but no location information." <+>- "The module is:" <+>- maybe "<unknown>" (ppr . moduleName)- (nameModule_maybe name'))-- span' -> return (info,name',span')---- | Find any uses of the given identifier in the codebase.-findNameUses :: (GhcMonad m)- => Map ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc 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 ModuleName ModInfo- -> RealSrcSpan- -> ModInfo- -> String- -> ExceptT SDoc 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 "Couldn't resolve to any modules."- 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 ModuleName ModInfo- -> Name- -> ExceptT SDoc m Name-resolveNameFromModule infos name = do- modL <- maybe (throwE $ "No module for" <+> ppr name) return $- nameModule_maybe name-- info <- maybe (throwE (ppr (moduleUnit modL) <> ":" <>- ppr modL)) return $- M.lookup (moduleName modL) infos-- let all_names = modInfo_rdrs info-- maybe (throwE "No matching export in any local modules.") return $- 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 ModuleName ModInfo- -> RealSrcSpan- -> String- -> ExceptT SDoc m (ModInfo, Type)-findType infos span0 string = do- name <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $- guessModule infos (srcSpanFilePath span0)-- info <- maybeToExceptT "No module info for current file! Try loading it?" $- 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 ModuleName ModInfo -> FilePath -> MaybeT m ModuleName-guessModule infos fp = do- target <- lift $ guessTarget fp Nothing Nothing- case targetId target of- TargetModule mn -> return mn- TargetFile fp' _ -> guessModule' fp'- where- guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName- guessModule' fp' = case findModByFp fp' of- Just mn -> return mn- Nothing -> do- fp'' <- liftIO (makeRelativeToCurrentDirectory fp')-- target' <- lift $ guessTarget fp'' Nothing Nothing- case targetId target' of- TargetModule mn -> return mn- _ -> MaybeT . pure $ findModByFp fp''-- findModByFp :: FilePath -> Maybe ModuleName- findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)- where- mifp :: (ModuleName, ModInfo) -> Maybe FilePath- mifp = ml_hs_file . ms_location . modinfoSummary . snd----- | Collect type info data for the loaded modules.-collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]- -> m (Map ModuleName 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) => ModuleName -> m ModInfo-getModInfo name = do- m <- getModSummary name- p <- parseModule m- typechecked <- typecheckModule p- let allTypes = processAllTypeCheckedModule typechecked- module_info = tm_checked_module_info typechecked- !rdr_env = case modInfoRdrEnv module_info of- Just rdrs -> Strict.Just rdrs- -- NB: this has already been deeply forced; no need to do that again.- -- See test case T15369 and Note [Forcing GREInfo] in GHC.Types.GREInfo.- Nothing -> Strict.Nothing- ts <- liftIO $ getModificationTime $ srcFilePath m- return $- ModInfo- { modinfoSummary = m- , modinfoSpans = allTypes- , modinfoRdrEnv = rdr_env- , modinfoLastUpdate = ts- }---- | Get the 'Name's from the 'GlobalRdrEnv' of the 'ModInfo', if any.-modInfo_rdrs :: ModInfo -> [Name]-modInfo_rdrs mi =- case modinfoRdrEnv mi of- Strict.Nothing -> []- Strict.Just env -> map greName $ globalRdrEnvElts env---- | 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 (HsWrap _ 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.10/Clash/GHCi/UI/Monad.hs
@@ -1,575 +0,0 @@-{-# LANGUAGE FlexibleInstances, DeriveFunctor, DerivingVia #-}-{-# 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,-- printForUserNeverQualify,- printForUserModInfo, printForUserGlobalRdrEnv,- printForUser, printForUserPartWay, 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.Types.Name.Reader-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 qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx)-import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)-import GHC.Runtime.Interpreter-import GHC.Runtime.Context-import GHCi.RemoteTypes-import Clash.GHCi.UI.Exception (printGhciException)-import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)-import GHC.Hs.Utils-import GHC.Utils.Misc-import GHC.Utils.Logger--import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch)-import Numeric-import Data.Array-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---------------------------------------------------------------------------------- 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,- multiMode :: Bool,- 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.- 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)-- short_help :: String,- -- ^ help text to display to a user- long_help :: String,- lastErrorLocations :: IORef [(FastString, Int)],-- mod_infos :: !(Map ModuleName ModInfo),-- flushStdHandles :: ForeignHValue,- -- ^ @hFlush stdout; hFlush stderr@ in the interpreter- noBuffering :: ForeignHValue,- -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr- ifaceCache :: ModIfaceCache- }--type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]---- | 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 } = throwM e-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- { breakModule :: !GHC.Module- , breakLoc :: !SrcSpan- , breakTick :: {-# UNPACK #-} !Int- , breakEnabled:: !Bool- , onBreakCmd :: String- }--instance Eq BreakLocation where- loc1 == loc2 = breakModule loc1 == breakModule loc2 &&- breakTick loc1 == breakTick 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 $ breakModule 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) })--printForUserNeverQualify :: GhcMonad m => SDoc -> m ()-printForUserNeverQualify doc = do- dflags <- GHC.getInteractiveDynFlags- liftIO $ Ppr.printForUser dflags stdout neverQualify AllTheWay doc--printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()-printForUserModInfo info = printForUserGlobalRdrEnv (GHC.modInfoRdrEnv info)--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.printForUser 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---- | 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 => (SrcSpan -> Bool) -> GHC.SingleStep -> Maybe Int -> m GHC.ExecResult-resume canLogSpan step mbIgnoreCnt = do- st <- getGHCiState- reifyGHCi $ \x ->- withProgName (progname st) $- withArgs (args st) $- reflectGHCi x $ do- GHC.resumeExec canLogSpan 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.10/Clash/GHCi/Util.hs
@@ -1,16 +0,0 @@-{-# 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.10/Clash/Main.hs
@@ -1,1240 +0,0 @@-{-# 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-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, compileFile )-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.Ways-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.Env-import GHC.Unit (UnitId, homeUnitDepends)-import GHC.Unit.Home.ModInfo (emptyHomePackageTable)-import GHC.Unit.Module ( ModuleName, mkModuleName )-import GHC.Unit.Module.ModIface-import GHC.Unit.State ( pprUnits, pprUnitsSimple )-import GHC.Unit.Finder ( findImportedModule, FindResult(..) )-import qualified GHC.Unit.State as State-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.Misc-import GHC.Utils.Panic-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Monad ( liftIO, mapMaybeM )-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.SysTools.BaseDir--import GHC.Iface.Load-import GHC.Iface.Recomp.Binary ( fingerprintBinMem )--import GHC.Tc.Utils.Monad ( initIfaceCheck )-import GHC.Iface.Errors.Ppr---- Standard Haskell libraries-import System.IO-import System.Environment-import System.Exit-import System.FilePath-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except (throwE, runExceptT)-import Data.Char-import Data.List ( partition, intercalate, (\\) )-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Maybe-import Prelude-import GHC.ResponseFile (expandResponse)-import Data.Bifunctor-import GHC.Data.Graph.Directed-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 GHC.Data.EnumSet as EnumSet-import 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 ->- -- start our GHC session- 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- (dflags3, fileish_args, dynamicFlagWarnings) <-- GHC.parseDynamicFlags logger2 dflags2 args'---- Propagate -Werror to Clash- liftIO . modifyIORef' clashOpts $ \opts ->- opts { opt_werror = EnumSet.member Opt_WarnIsError (generalFlags dflags3) }-- let dflags4 = if backendNeedsFullWays bcknd &&- not (gopt Opt_ExternalInterpreter dflags3)- then- let platform = targetPlatform dflags3- dflags3a = dflags3 { targetWays_ = hostFullWays }- dflags3b = foldl gopt_set dflags3a- $ concatMap (wayGeneralFlags platform)- hostFullWays- dflags3c = foldl gopt_unset dflags3b- $ concatMap (wayUnsetGeneralFlags platform)- hostFullWays- in dflags3c- else- dflags3-- 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-- -- 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- Nothing -> do- case srcs of- [] -> return []- _ -> do- s <- initMake srcs- return $ map (uncurry (,Nothing,)) s- interactiveUI (defaultGhciSettings clashOpts) hs_srcs maybe_expr-#endif----- -------------------------------------------------------------------------------- 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)- && isInterpretiveMode mode- && 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.)"))---------------------------------------------------------------------------------- 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"---- ------------------------------------------------------------------------------- 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- 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))--initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)]-initMake srcs = do- let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs-- hsc_env <- GHC.getSession-- -- if we have no haskell sources from which to do a dependency- -- analysis, then just do one-shot compilation and/or linking.- -- This means that "ghc Foo.o Bar.o -o baz" links the program as- -- we expect.- if (null hs_srcs)- then liftIO (oneShot hsc_env NoStop srcs) >> return []- else do-- o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x)- non_hs_srcs- dflags <- GHC.getSessionDynFlags- let dflags' = dflags { ldInputs = map (FileOption "") o_files- ++ ldInputs dflags }- _ <- GHC.setSessionDynFlags dflags'- return hs_srcs---- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.-removeRTS :: [String] -> [String]-removeRTS ("+RTS" : xs) =- case dropWhile (/= "-RTS") xs of- [] -> []- (_ : ys) -> removeRTS ys-removeRTS (y:ys) = y : removeRTS ys-removeRTS [] = []--initMulti :: NE.NonEmpty String -> Ghc ([(String, Maybe UnitId, Maybe Phase)])-initMulti unitArgsFiles = do- hsc_env <- GHC.getSession- let logger = hsc_logger hsc_env- initial_dflags <- GHC.getSessionDynFlags-- dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do- when (verbosity initial_dflags > 2) (liftIO $ print f)- args <- liftIO $ expandResponse [f]- (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine initial_dflags (map (mkGeneralLocated f) (removeRTS args))- handleSourceError (\e -> do- GHC.printException e- liftIO $ exitWith (ExitFailure 1)) $ do- liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)-- let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)- dflags4 = offsetDynFlags dflags3-- let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs-- -- This is dubious as the whole unit environment won't be set-up correctly, but- -- that doesn't matter for what we use it for (linking and oneShot)- let dubious_hsc_env = hscSetFlags dflags4 hsc_env- -- if we have no haskell sources from which to do a dependency- -- analysis, then just do one-shot compilation and/or linking.- -- This means that "ghc Foo.o Bar.o -o baz" links the program as- -- we expect.- if (null hs_srcs)- then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, [])- else do-- o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x)- non_hs_srcs- let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files- ++ ldInputs dflags4 }-- liftIO $ checkOptions DoMake dflags5 srcs objs []-- pure (dflags5, hs_srcs)-- let- unitDflags = NE.map fst dynFlagsAndSrcs- srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs- (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs))-- checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))-- let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags- home_units = unitEnv_keys initial_home_graph-- home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do- let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv- hue_flags = homeUnitEnv_dflags homeUnitEnv- dflags = homeUnitEnv_dflags homeUnitEnv- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units-- updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants- pure $ HomeUnitEnv- { homeUnitEnv_units = unit_state- , homeUnitEnv_unit_dbs = Just dbs- , homeUnitEnv_dflags = updated_dflags- , homeUnitEnv_hpt = emptyHomePackageTable- , homeUnitEnv_home_unit = Just home_unit- }-- checkUnitCycles initial_dflags home_unit_graph-- let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph- unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }-- GHC.setSession final_hsc_env-- -- if we have no haskell sources from which to do a dependency- -- analysis, then just do one-shot compilation and/or linking.- -- This means that "ghc Foo.o Bar.o -o baz" links the program as- -- we expect.- if (null hs_srcs)- then do- liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."- liftIO $ exitWith (ExitFailure 1)- else do--{-- o_files <- liftIO $ mapMaybeM- (\(src, uid, mphase) ->- compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)- )- (concat non_hs_srcs)- -}-- -- MP: This should probably modify dflags for each unit?- --let dflags' = dflags { ldInputs = map (FileOption "") o_files- -- ++ ldInputs dflags }- return $ concat hs_srcs---- | Check that we don't have multiple units with the same UnitId.--checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc ()-checkUnitCycles dflags graph = processSCCs sccs- where- mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId- mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue))- nodes = map mkNode (unitEnv_elts graph)-- sccs = stronglyConnCompFromEdgedVerticesOrd nodes-- processSCCs [] = return ()- processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs- processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)--- cycle_err uids =- hang (text "Units form a dependency cycle:")- 2- (one_err uids)-- one_err uids = vcat $- (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)- ++ [text "-" <+> ppr final]- where- start = init uids- final = last uids--checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()-checkDuplicateUnits dflags flags =- unless (null duplicate_ids)- (throwGhcException $ CmdLineError $ showSDoc dflags multi_err)-- where- uids = map (second homeUnitId_) flags- deduplicated_uids = ordNubOn snd uids- duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids)-- duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids-- one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp-- multi_err =- hang (text "Multiple units with the same unit-id:")- 2- (vcat (map one_err duplicate_flags))---offsetDynFlags :: DynFlags -> DynFlags-offsetDynFlags dflags =- dflags { hiDir = c hiDir- , objectDir = c objectDir- , stubDir = c stubDir- , hieDir = c hieDir- , dumpDir = c dumpDir }-- where- c f = augment_maybe (f dflags)-- augment_maybe Nothing = Nothing- augment_maybe (Just f) = Just (augment f)- augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f- | otherwise = f---createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> (HomeUnitGraph, UnitId)-createUnitEnvFromFlags unitDflags =- let- newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing- unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags- activeUnit = fst $ NE.head unitEnvList- in- (unitEnv_new (Map.fromList (NE.toList (unitEnvList))), activeUnit)---- ------------------------------------------------------------------------------ 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 Paths_clash_ghc.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-- 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 . mi_final_exts) ifaces- f <- fingerprintBinMem bh-- putStrLn (showPpr dflags f)---------------------------------------------------------------------------------- HDL Generation--makeHDL'- :: forall backend- . Clash.Backend.Backend backend- => Proxy backend- -> Ghc ()- -> IORef ClashOpts- -> [(String,Maybe Phase)]- -> Ghc ()-makeHDL' _ _ _ [] = throwGhcException (CmdLineError "No input files")-makeHDL' proxy startAction r srcs = makeHDL proxy startAction r $ fmap 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)---- -------------------------------------------------------------------------------- Util--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-ghc/Clash/GHC/Evaluator/Primitive.hs view
@@ -18,5890 +18,5956 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module Clash.GHC.Evaluator.Primitive- ( ghcPrimStep- , ghcPrimUnwind- , isUndefinedPrimVal- , isUndefinedXPrimVal- ) where--import Control.DeepSeq (force)-import Control.Exception (ArithException(..), Exception, tryJust, evaluate)-import Control.Monad.State.Strict (State, MonadState)-import qualified Control.Monad.State.Strict as State-import Control.Monad.Trans.Except (runExcept)-import Data.Binary.IEEE754 (doubleToWord, floatToWord, wordToDouble, wordToFloat)-import Data.Bits-import qualified Data.ByteString.Internal as BS-import Data.Char (chr,ord)-import qualified Data.Either as Either-import Data.Maybe (fromMaybe, mapMaybe)-import qualified Data.List as List-import qualified Data.Primitive.ByteArray as BA-import Data.Proxy (Proxy)-import Data.Reflection (reifyNat)-import Data.Text (Text)-import qualified Data.Text as Text-import Data.Text.Extra (showt)-import GHC.Exts (IsList(..))-import GHC.Float-import GHC.Int-import GHC.Integer- (decodeDoubleInteger,encodeDoubleInteger,compareInteger,orInteger,andInteger,- xorInteger,complementInteger,absInteger,signumInteger)-#if MIN_VERSION_base(4,16,0)-import GHC.Num.Integer (Integer (..), integerEncodeFloat#)-#elif MIN_VERSION_base(4,15,0)-import GHC.Num.Integer- (Integer (..), integerEncodeFloat#, integerToFloat#, integerToDouble#)-#else-import GHC.Integer.GMP.Internals- (Integer (..), BigNat (..))-#endif-#if MIN_VERSION_base(4,15,0)-import GHC.Num.Natural (naturalSubUnsafe)-#endif-import GHC.Natural-import GHC.ForeignPtr-import GHC.Prim-import GHC.Real (Ratio (..))-import GHC.TypeLits (KnownNat)-import GHC.Types (IO (..))-import GHC.Word-import System.IO.Unsafe (unsafeDupablePerformIO)-#if MIN_VERSION_ghc(9,4,0)-import Data.Bifunctor (first)-import qualified Data.Text.Array as Text-import qualified Data.Text.Internal as Text-#endif--#if MIN_VERSION_ghc(9,0,0)-import GHC.Types.Basic (Boxity (..))-import GHC.Types.Name (getSrcSpan, nameOccName, occNameString)-import GHC.Builtin.Names (trueDataConKey, falseDataConKey)-import qualified GHC.Core.TyCon as TyCon-import GHC.Builtin.Types (tupleTyCon)-#else-import BasicTypes (Boxity (..))-import Name (getSrcSpan, nameOccName, occNameString)-import PrelNames (trueDataConKey, falseDataConKey)-import qualified TyCon-import TysWiredIn (tupleTyCon)-#endif--import Clash.Class.BitPack (pack,unpack)-import Clash.Core.DataCon (DataCon (..))-import Clash.Core.Evaluator.Types-import Clash.Core.HasType (piResultTys, applyTypeToArgs)-import Clash.Core.Literal (Literal (..))-import Clash.Core.Name- (Name (..), NameSort (..), mkUnsafeSystemName)-import Clash.Core.Pretty (showPpr)-import Clash.Core.Term- (IsMultiPrim (..), Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps,- PrimUnfolding(..), collectArgs)-import Clash.Core.Type- (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp,- splitFunForallTy, tyView)-import Clash.Core.TyCon- (TyConMap, TyConName, tyConDataCons)-import Clash.Core.TysPrim-import Clash.Core.Util- (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, mkSelectorCase,undefinedPrims,- undefinedXPrims)-import Clash.Core.Var (mkLocalId, mkTyVar)-import qualified Clash.Data.UniqMap as UniqMap-import Clash.Debug-import Clash.GHC.GHC2Core (modNameM)-import Clash.Unique (fromGhcUnique)-import Clash.Util- (MonadUnique (..), clogBase, flogBase, curLoc)-import Clash.Util.Supply (Supply,freshId)-import Clash.Normalize.PrimitiveReductions- (typeNatMul, typeNatSub, typeNatAdd, vecLastPrim, vecInitPrim, vecHeadPrim,- vecTailPrim, mkVecCons, mkVecNil)--import qualified Clash.Normalize.Primitives as NP-import Clash.Promoted.Nat.Unsafe (unsafeSNat)-import qualified Clash.Sized.Internal.BitVector as BitVector-import qualified Clash.Sized.Internal.Signed as Signed-import qualified Clash.Sized.Internal.Unsigned as Unsigned-import Clash.Sized.Internal.BitVector(BitVector(..), Bit(..))-import Clash.Sized.Internal.Signed (Signed (..))-import Clash.Sized.Internal.Unsigned (Unsigned (..))-import Clash.XException (isX)--import {-# SOURCE #-} Clash.GHC.Evaluator--isUndefinedPrimVal :: Value -> Bool-isUndefinedPrimVal (PrimVal (PrimInfo{primName}) _ _) =- primName `elem` undefinedPrims-isUndefinedPrimVal _ = False--isUndefinedXPrimVal :: Value -> Bool-isUndefinedXPrimVal (PrimVal (PrimInfo{primName}) _ _) =- primName `elem` undefinedXPrims-isUndefinedXPrimVal _ = False---- | Evaluation of primitive operations.-ghcPrimUnwind :: PrimUnwind-ghcPrimUnwind tcm p tys vs v [] m- | primName p `elem` [ "Clash.Sized.Internal.Index.fromInteger#"- , "GHC.CString.unpackCString#"- , Text.pack (show 'NP.removedArg)- , "GHC.Prim.MutableByteArray#"- , Text.pack (show 'NP.undefined)- , Text.pack (show 'NP.undefinedX)- ]- -- The above primitives are actually values, and not operations.- = ghcUnwind (PrimVal p tys (vs ++ [v])) m tcm- | primName p == "Clash.Sized.Internal.BitVector.fromInteger#"- = case (vs,v) of- ([naturalLiteral -> Just n,mask], integerLiteral -> Just i) ->- ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), mask, Lit (IntegerLiteral (wrapUnsigned n i))]) m tcm- _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))- | primName p == "Clash.Sized.Internal.BitVector.fromInteger##"- = case (vs,v) of- ([mask], integerLiteral -> Just i) ->- ghcUnwind (PrimVal p tys [mask, Lit (IntegerLiteral (wrapUnsigned 1 i))]) m tcm- _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))- | primName p == "Clash.Sized.Internal.Signed.fromInteger#"- = case (vs,v) of- ([naturalLiteral -> Just n],integerLiteral -> Just i) ->- ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapSigned n i))]) m tcm- _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))- | primName p == "Clash.Sized.Internal.Unsigned.fromInteger#"- = case (vs,v) of- ([naturalLiteral -> Just n],integerLiteral -> Just i) ->- ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapUnsigned n i))]) m tcm- _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))- | isUndefinedPrimVal v- = let tyArgs = map Right tys- tmArgs = map (Left . valToTerm) (vs ++ [v])- in Just $ flip setTerm m $ TyApp (Prim NP.undefined) $- applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)- | isUndefinedXPrimVal v- = let tyArgs = map Right tys- tmArgs = map (Left . valToTerm) (vs ++ [v])- in Just $ flip setTerm m $ TyApp (Prim NP.undefinedX) $- applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)- | otherwise- = ghcPrimStep tcm (forcePrims m) p tys (vs ++ [v]) m--ghcPrimUnwind tcm p tys vs v [e] m0- -- Note [Lazy primitives]- -- ~~~~~~~~~~~~~~~~~~~~~~- --- -- Primitives are usually considered undefined when one of their arguments is- -- (unless they're unused). _Some_ primitives can still yield a result even- -- though one of their arguments is undefined. It turns out that all primitives- -- exhibiting this property happen to be "lazy" in their last argument. Thus,- -- all the cases can be covered by a match on [e] and their names:- | primName p `elem` [ "Clash.Sized.Vector.lazyV"- , "Clash.Sized.Vector.replicate"- , "Clash.Sized.Vector.replace_int"- , "GHC.Classes.&&"- , "GHC.Classes.||"- , showt 'BitVector.xToBV- , "Clash.Sized.Vector.imap_go"- ]- = if isUndefinedPrimVal v then- let tyArgs = map Right tys- tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ [Left e]- in Just $ flip setTerm m0 $ TyApp (Prim NP.undefined) $- applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)- else- let (m1,i) = newLetBinding tcm m0 e- in ghcPrimStep tcm (forcePrims m0) p tys (vs ++ [v,Suspend (Var i)]) m1--ghcPrimUnwind tcm p tys vs (collectValueTicks -> (v, ts)) (e:es) m- | isUndefinedPrimVal v- = let tyArgs = map Right tys- tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ map Left (e:es)- in Just $ flip setTerm m $ TyApp (Prim NP.undefined) $- applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)- | otherwise- = Just . setTerm e $ stackPush (PrimApply p tys (vs ++ [foldr TickValue v ts]) es) m--newtype PrimEvalMonad a = PEM (State Supply a)- deriving (Functor, Applicative, Monad, MonadState Supply)--instance MonadUnique PrimEvalMonad where- getUniqueM = PEM $ State.state (\s -> case freshId s of (!i,!s') -> (i,s'))--runPEM :: PrimEvalMonad a -> Supply -> (a, Supply)-runPEM (PEM m) = State.runState m--ghcPrimStep :: PrimStep-ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of--------------------- GHC.Prim.Char#------------------- "GHC.Prim.gtChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.geChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.eqChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim.neChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.ltChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.leChar#" | Just (i,j) <- charLiterals args- -> reduce (boolToIntLiteral (i <= j))- "GHC.Prim.ord#" | [i] <- charLiterals' args- -> reduce (integerToIntLiteral (toInteger $ ord i))--------------------- GHC.Prim.Int#------------------ "GHC.Prim.+#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i+j))- "GHC.Prim.-#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i-j))- "GHC.Prim.*#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i*j))-- "GHC.Prim.mulIntMayOflo#" | Just (i,j) <- intLiterals args- -> let !(I# a) = fromInteger i- !(I# b) = fromInteger j- c :: Int#- c = mulIntMayOflo# a b- in reduce (integerToIntLiteral (toInteger $ I# c))-- "GHC.Prim.quotInt#" | Just (i,j) <- intLiterals args- -> reduce $ catchDivByZero (integerToIntLiteral (i `quot` j))- "GHC.Prim.remInt#" | Just (i,j) <- intLiterals args- -> reduce $ catchDivByZero (integerToIntLiteral (i `rem` j))- "GHC.Prim.quotRemInt#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- ret = mkApps (Data tupDc) (map Right tyArgs ++- [Left $ catchDivByZero (integerToIntLiteral q)- ,Left $ catchDivByZero (integerToIntLiteral r)])- in reduce ret-- "GHC.Prim.andI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i .&. j))- "GHC.Prim.orI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i .|. j))- "GHC.Prim.xorI#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `xor` j))- "GHC.Prim.notI#" | [i] <- intLiterals' args- -> reduce (integerToIntLiteral (complement i))-- "GHC.Prim.negateInt#"- | [Lit (IntLiteral i)] <- args- -> reduce (integerToIntLiteral (negate i))-- "GHC.Prim.addIntC#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(I# a) = fromInteger i- !(I# b) = fromInteger j- !(# d, c #) = addIntC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])- "GHC.Prim.subIntC#" | Just (i,j) <- intLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(I# a) = fromInteger i- !(I# b) = fromInteger j- !(# d, c #) = subIntC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])-- "GHC.Prim.>#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.>=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.==#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim./=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.<#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.<=#" | Just (i,j) <- intLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Prim.chr#" | [i] <- intLiterals' args- -> reduce (charToCharLiteral (chr $ fromInteger i))-- "GHC.Prim.int2Word#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . WordLiteral . toInteger $ (fromInteger :: Integer -> Word) i -- for overflow behavior-- "GHC.Prim.int2Float#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . FloatLiteral . floatToWord $ fromInteger i- "GHC.Prim.int2Double#"- | [Lit (IntLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . doubleToWord $ fromInteger i-- "GHC.Prim.word2Float#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . FloatLiteral . floatToWord $ fromInteger i- "GHC.Prim.word2Double#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . DoubleLiteral . doubleToWord $ fromInteger i-- "GHC.Prim.uncheckedIShiftL#"- | [ Lit (IntLiteral i)- , Lit (IntLiteral s)- ] <- args- -> reduce (integerToIntLiteral (i `shiftL` fromInteger s))- "GHC.Prim.uncheckedIShiftRA#"- | [ Lit (IntLiteral i)- , Lit (IntLiteral s)- ] <- args- -> reduce (integerToIntLiteral (i `shiftR` fromInteger s))- "GHC.Prim.uncheckedIShiftRL#" | Just (i,j) <- intLiterals args- -> let !(I# a) = fromInteger i- !(I# b) = fromInteger j- c :: Int#- c = uncheckedIShiftRL# a b- in reduce (integerToIntLiteral (toInteger $ I# c))---------------------- GHC.Prim.Word#------------------- "GHC.Prim.plusWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i+j))-- "GHC.Prim.subWordC#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# d, c #) = subWordC# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# d)- , Left (Literal . IntLiteral . toInteger $ I# c)])-- "GHC.Prim.plusWord2#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# h', l #) = plusWord2# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# h')- , Left (Literal . WordLiteral . toInteger $ W# l)])-- "GHC.Prim.minusWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i-j))- "GHC.Prim.timesWord#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i*j))-- "GHC.Prim.timesWord2#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(# h', l #) = timesWord2# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . WordLiteral . toInteger $ W# h')- , Left (Literal . WordLiteral . toInteger $ W# l)])-- "GHC.Prim.quotWord#" | Just (i,j) <- wordLiterals args- -> reduce $ catchDivByZero (integerToWordLiteral (i `quot` j))- "GHC.Prim.remWord#" | Just (i,j) <- wordLiterals args- -> reduce $ catchDivByZero (integerToWordLiteral (i `rem` j))- "GHC.Prim.quotRemWord#" | Just (i,j) <- wordLiterals args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- ret = mkApps (Data tupDc) (map Right tyArgs ++- [Left $ catchDivByZero (integerToWordLiteral q)- ,Left $ catchDivByZero (integerToWordLiteral r)])- in reduce ret- "GHC.Prim.quotRemWord2#" | [i,j,k'] <- wordLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(W# a) = fromInteger i- !(W# b) = fromInteger j- !(W# c) = fromInteger k'- !(# x, y #) = quotRemWord2# a b c- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# x)- , Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# y)])-- "GHC.Prim.and#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i .&. j))- "GHC.Prim.or#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i .|. j))- "GHC.Prim.xor#" | Just (i,j) <- wordLiterals args- -> reduce (integerToWordLiteral (i `xor` j))- "GHC.Prim.not#" | [i] <- wordLiterals' args- -> reduce (integerToWordLiteral (complement i))-- "GHC.Prim.uncheckedShiftL#"- | [ Lit (WordLiteral w)- , Lit (IntLiteral i)- ] <- args- -> reduce (Literal (WordLiteral (w `shiftL` fromInteger i)))- "GHC.Prim.uncheckedShiftRL#"- | [ Lit (WordLiteral w)- , Lit (IntLiteral i)- ] <- args- -> reduce (Literal (WordLiteral (w `shiftR` fromInteger i)))-- "GHC.Prim.word2Int#"- | [Lit (WordLiteral i)] <- args- -> reduce . Literal . IntLiteral . toInteger $ (fromInteger :: Integer -> Int) i -- for overflow behavior-- "GHC.Prim.gtWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i > j))- "GHC.Prim.geWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i >= j))- "GHC.Prim.eqWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i == j))- "GHC.Prim.neWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i /= j))- "GHC.Prim.ltWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i < j))- "GHC.Prim.leWord#" | Just (i,j) <- wordLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Prim.popCnt8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word8) $ i- "GHC.Prim.popCnt16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.popCnt32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.popCnt64#" | [i] <- word64Literals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.popCnt#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.clz8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word8) $ i- "GHC.Prim.clz16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.clz32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.clz64#" | [i] <- word64Literals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.clz#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.ctz8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 8 - 1)- "GHC.Prim.ctz16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 16 - 1)- "GHC.Prim.ctz32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 32 - 1)- "GHC.Prim.ctz64#" | [i] <- word64Literals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word64) $ i .&. (bit 64 - 1)- "GHC.Prim.ctz#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i-- "GHC.Prim.byteSwap16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap16 . (fromInteger :: Integer -> Word16) $ i- "GHC.Prim.byteSwap32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap32 . (fromInteger :: Integer -> Word32) $ i- "GHC.Prim.byteSwap64#" | [i] <- word64Literals' args- -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i- "GHC.Prim.byteSwap#" | [i] <- wordLiterals' args -- assume 64bits- -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i--#if MIN_VERSION_base(4,14,0)- "GHC.Prim.bitReverse#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i -- assume 64bits- "GHC.Prim.bitReverse8#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse8 . fromInteger $ i- "GHC.Prim.bitReverse16#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse16 . fromInteger $ i- "GHC.Prim.bitReverse32#" | [i] <- wordLiterals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse32 . fromInteger $ i- "GHC.Prim.bitReverse64#" | [i] <- word64Literals' args- -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i-#endif---------------- Narrowing-------------- "GHC.Prim.narrow8Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow8Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow16Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow16Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow32Int#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow32Int# a- in reduce . Literal . IntLiteral . toInteger $ I# b- "GHC.Prim.narrow8Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow8Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b- "GHC.Prim.narrow16Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow16Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b- "GHC.Prim.narrow32Word#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow32Word# a- in reduce . Literal . WordLiteral . toInteger $ W# b--#if MIN_VERSION_base(4,16,0)------------ Int8#---------- "GHC.Prim.intToInt8#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow8Int# a- in reduce . Literal . Int8Literal . toInteger $ I# b- "GHC.Prim.int8ToInt#" | [i] <- int8Literals' args- -> reduce . Literal $ IntLiteral i- "GHC.Prim.negateInt8" | [i] <- int8Literals' args- -> let !(I8# a) = fromInteger i- in reduce (Literal (Int8Literal (toInteger (I8# (negateInt8# a)))))- "GHC.Prim.plusInt8#" | Just r <- liftI8 plusInt8# args- -> reduce r- "GHC.Prim.subInt8#" | Just r <- liftI8 subInt8# args- -> reduce r- "GHC.Prim.timesInt8#" | Just r <- liftI8 timesInt8# args- -> reduce r- "GHC.Prim.quotInt8#" | Just r <- liftI8 quotInt8# args- -> reduce r- "GHC.Prim.remInt8#" | Just r <- liftI8 remInt8# args- -> reduce r- "GHC.Prim.quotRemInt8#"- | [i, j] <- int8Literals' args- , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty- , (Just tupTc) <- UniqMap.lookup tupTcNm tcm- , [tupDc] <- tyConDataCons tupTc- -> let !(I8# a) = fromInteger i- !(I8# b) = fromInteger j- !(# q, r #) = quotRemInt8# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Int8Literal (toInteger (I8# q))))- , Left (Literal (Int8Literal (toInteger (I8# r))))])- "GHC.Prim.uncheckedShiftLInt8#" | Just r <- liftI8I uncheckedShiftLInt8# args- -> reduce r- "GHC.Prim.uncheckedShiftRAInt8#" | Just r <- liftI8I uncheckedShiftRAInt8# args- -> reduce r- "GHC.Prim.uncheckedShiftRLInt8#" | Just r <- liftI8I uncheckedShiftRLInt8# args- -> reduce r- "GHC.Prim.int8ToWord8#" | [i] <- int8Literals' args- -> let !(I8# a) = fromInteger i- in reduce (Literal (Word8Literal (toInteger (W8# (int8ToWord8# a)))))- "GHC.Prim.eqInt8#" | Just r <- liftI8RI eqInt8# args- -> reduce r- "GHC.Prim.geInt8#" | Just r <- liftI8RI geInt8# args- -> reduce r- "GHC.Prim.gtInt8#" | Just r <- liftI8RI gtInt8# args- -> reduce r- "GHC.Prim.leInt8#" | Just r <- liftI8RI leInt8# args- -> reduce r- "GHC.Prim.ltInt8#" | Just r <- liftI8RI ltInt8# args- -> reduce r- "GHC.Prim.neInt8#" | Just r <- liftI8RI neInt8# args- -> reduce r-------------- Int16#----------- "GHC.Prim.intToInt16#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow16Int# a- in reduce . Literal . Int16Literal . toInteger $ I# b- "GHC.Prim.int16ToInt#" | [i] <- int16Literals' args- -> reduce . Literal $ IntLiteral i- "GHC.Prim.negateInt16" | [i] <- int16Literals' args- -> let !(I16# a) = fromInteger i- in reduce (Literal (Int16Literal (toInteger (I16# (negateInt16# a)))))- "GHC.Prim.plusInt16#" | Just r <- liftI16 plusInt16# args- -> reduce r- "GHC.Prim.subInt16#" | Just r <- liftI16 subInt16# args- -> reduce r- "GHC.Prim.timesInt16#" | Just r <- liftI16 timesInt16# args- -> reduce r- "GHC.Prim.quotInt16#" | Just r <- liftI16 quotInt16# args- -> reduce r- "GHC.Prim.remInt16#" | Just r <- liftI16 remInt16# args- -> reduce r- "GHC.Prim.quotRemInt16#"- | [i, j] <- int16Literals' args- , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty- , (Just tupTc) <- UniqMap.lookup tupTcNm tcm- , [tupDc] <- tyConDataCons tupTc- -> let !(I16# a) = fromInteger i- !(I16# b) = fromInteger j- !(# q, r #) = quotRemInt16# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Int16Literal (toInteger (I16# q))))- , Left (Literal (Int16Literal (toInteger (I16# r))))])- "GHC.Prim.uncheckedShiftLInt16#" | Just r <- liftI16I uncheckedShiftLInt16# args- -> reduce r- "GHC.Prim.uncheckedShiftRAInt16#" | Just r <- liftI16I uncheckedShiftRAInt16# args- -> reduce r- "GHC.Prim.uncheckedShiftRLInt16#" | Just r <- liftI16I uncheckedShiftRLInt16# args- -> reduce r- "GHC.Prim.int16ToWord16#" | [i] <- int16Literals' args- -> let !(I16# a) = fromInteger i- in reduce (Literal (Word16Literal (toInteger (W16# (int16ToWord16# a)))))- "GHC.Prim.eqInt16#" | Just r <- liftI16RI eqInt16# args- -> reduce r- "GHC.Prim.geInt16#" | Just r <- liftI16RI geInt16# args- -> reduce r- "GHC.Prim.gtInt16#" | Just r <- liftI16RI gtInt16# args- -> reduce r- "GHC.Prim.leInt16#" | Just r <- liftI16RI leInt16# args- -> reduce r- "GHC.Prim.ltInt16#" | Just r <- liftI16RI ltInt16# args- -> reduce r- "GHC.Prim.neInt16#" | Just r <- liftI16RI neInt16# args- -> reduce r-------------- Int32#----------- "GHC.Prim.intToInt32#" | [i] <- intLiterals' args- -> let !(I# a) = fromInteger i- b = narrow32Int# a- in reduce . Literal . Int32Literal . toInteger $ I# b- "GHC.Prim.int32ToInt#" | [i] <- int32Literals' args- -> reduce . Literal $ IntLiteral i- "GHC.Prim.negateInt32" | [i] <- int32Literals' args- -> let !(I32# a) = fromInteger i- in reduce (Literal (Int32Literal (toInteger (I32# (negateInt32# a)))))- "GHC.Prim.plusInt32#" | Just r <- liftI32 plusInt32# args- -> reduce r- "GHC.Prim.subInt32#" | Just r <- liftI32 subInt32# args- -> reduce r- "GHC.Prim.timesInt32#" | Just r <- liftI32 timesInt32# args- -> reduce r- "GHC.Prim.quotInt32#" | Just r <- liftI32 quotInt32# args- -> reduce r- "GHC.Prim.remInt32#" | Just r <- liftI32 remInt32# args- -> reduce r- "GHC.Prim.quotRemInt32#"- | [i, j] <- int32Literals' args- , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty- , (Just tupTc) <- UniqMap.lookup tupTcNm tcm- , [tupDc] <- tyConDataCons tupTc- -> let !(I32# a) = fromInteger i- !(I32# b) = fromInteger j- !(# q, r #) = quotRemInt32# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Int32Literal (toInteger (I32# q))))- , Left (Literal (Int32Literal (toInteger (I32# r))))])- "GHC.Prim.uncheckedShiftLInt32#" | Just r <- liftI32I uncheckedShiftLInt32# args- -> reduce r- "GHC.Prim.uncheckedShiftRAInt32#" | Just r <- liftI32I uncheckedShiftRAInt32# args- -> reduce r- "GHC.Prim.uncheckedShiftRLInt32#" | Just r <- liftI32I uncheckedShiftRLInt32# args- -> reduce r- "GHC.Prim.int32ToWord32#" | [i] <- int32Literals' args- -> let !(I32# a) = fromInteger i- in reduce (Literal (Word32Literal (toInteger (W32# (int32ToWord32# a)))))- "GHC.Prim.eqInt32#" | Just r <- liftI32RI eqInt32# args- -> reduce r- "GHC.Prim.geInt32#" | Just r <- liftI32RI geInt32# args- -> reduce r- "GHC.Prim.gtInt32#" | Just r <- liftI32RI gtInt32# args- -> reduce r- "GHC.Prim.leInt32#" | Just r <- liftI32RI leInt32# args- -> reduce r- "GHC.Prim.ltInt32#" | Just r <- liftI32RI ltInt32# args- -> reduce r- "GHC.Prim.neInt32#" | Just r <- liftI32RI neInt32# args- -> reduce r-------------- Int64#-----------#if MIN_VERSION_base(4,17,0)- "GHC.Prim.intToInt64#" | [i] <- intLiterals' args- -> reduce (Literal (Int64Literal i))- "GHC.Prim.int64ToInt#" | [i] <- int64Literals' args- -> reduce . Literal $ IntLiteral i- "GHC.Prim.negateInt64" | [i] <- int64Literals' args- -> let !(I64# a) = fromInteger i- in reduce (Literal (Int64Literal (toInteger (I64# (negateInt64# a)))))- "GHC.Prim.plusInt64#" | Just r <- liftI64 plusInt64# args- -> reduce r- "GHC.Prim.subInt64#" | Just r <- liftI64 subInt64# args- -> reduce r- "GHC.Prim.timesInt64#" | Just r <- liftI64 timesInt64# args- -> reduce r- "GHC.Prim.quotInt64#" | Just r <- liftI64 quotInt64# args- -> reduce r- "GHC.Prim.remInt64#" | Just r <- liftI64 remInt64# args- -> reduce r- "GHC.Prim.uncheckedIShiftL64#" | Just r <- liftI64I uncheckedIShiftL64# args- -> reduce r- "GHC.Prim.uncheckedIShiftRA64#" | Just r <- liftI64I uncheckedIShiftRA64# args- -> reduce r- "GHC.Prim.uncheckedIShiftRL64#" | Just r <- liftI64I uncheckedIShiftRL64# args- -> reduce r- "GHC.Prim.int64ToWord64#" | [i] <- int64Literals' args- -> let !(I64# a) = fromInteger i- in reduce (Literal (Word64Literal (toInteger (W64# (int64ToWord64# a)))))- "GHC.Prim.eqInt64#" | Just r <- liftI64RI eqInt64# args- -> reduce r- "GHC.Prim.geInt64#" | Just r <- liftI64RI geInt64# args- -> reduce r- "GHC.Prim.gtInt64#" | Just r <- liftI64RI gtInt64# args- -> reduce r- "GHC.Prim.leInt64#" | Just r <- liftI64RI leInt64# args- -> reduce r- "GHC.Prim.ltInt64#" | Just r <- liftI64RI ltInt64# args- -> reduce r- "GHC.Prim.neInt64#" | Just r <- liftI64RI neInt64# args- -> reduce r-#endif-------------- Word8#----------- "GHC.Prim.wordToWord8#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow8Word# a- in reduce . Literal . Word8Literal . toInteger $ W# b- "GHC.Prim.word8ToWord#" | [i] <- word8Literals' args- -> reduce . Literal $ WordLiteral i- "GHC.Prim.plusWord8#" | Just r <- liftW8 plusWord8# args- -> reduce r- "GHC.Prim.subWord8#" | Just r <- liftW8 subWord8# args- -> reduce r- "GHC.Prim.timesWord8#" | Just r <- liftW8 timesWord8# args- -> reduce r- "GHC.Prim.quotWord8#" | Just r <- liftW8 quotWord8# args- -> reduce r- "GHC.Prim.remWord8#" | Just r <- liftW8 remWord8# args- -> reduce r- "GHC.Prim.quotRemWord8#"- | [i, j] <- word8Literals' args- , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty- , (Just tupTc) <- UniqMap.lookup tupTcNm tcm- , [tupDc] <- tyConDataCons tupTc- -> let !(W8# a) = fromInteger i- !(W8# b) = fromInteger j- !(# q, r #) = quotRemWord8# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Word8Literal (toInteger (W8# q))))- , Left (Literal (Word8Literal (toInteger (W8# r))))])- "GHC.Prim.andWord8#" | Just r <- liftW8 andWord8# args- -> reduce r- "GHC.Prim.orWord8#" | Just r <- liftW8 orWord8# args- -> reduce r- "GHC.Prim.xorWord8#" | Just r <- liftW8 xorWord8# args- -> reduce r- "GHC.Prim.notWord8#" | [i] <- word8Literals' args- -> let !(W8# a) = fromInteger i- in reduce (Literal (Word8Literal (toInteger (W8# (notWord8# a)))))- "GHC.Prim.uncheckedShiftLWord8#" | Just r <- liftW8I uncheckedShiftLWord8# args- -> reduce r- "GHC.Prim.uncheckedShiftRLWord8#" | Just r <- liftW8I uncheckedShiftRLWord8# args- -> reduce r- "GHC.Prim.word8ToInt8#" | [i] <- word8Literals' args- -> let !(W8# a) = fromInteger i- in reduce (Literal (Int8Literal (toInteger (I8# (word8ToInt8# a)))))- "GHC.Prim.eqWord8#" | Just r <- liftW8RI eqWord8# args- -> reduce r- "GHC.Prim.geWord8#" | Just r <- liftW8RI geWord8# args- -> reduce r- "GHC.Prim.gtWord8#" | Just r <- liftW8RI gtWord8# args- -> reduce r- "GHC.Prim.leWord8#" | Just r <- liftW8RI leWord8# args- -> reduce r- "GHC.Prim.ltWord8#" | Just r <- liftW8RI ltWord8# args- -> reduce r- "GHC.Prim.neWord8#" | Just r <- liftW8RI neWord8# args- -> reduce r--------------- Word16#------------ "GHC.Prim.wordToWord16#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow16Word# a- in reduce . Literal . Word16Literal . toInteger $ W# b- "GHC.Prim.word16ToWord#" | [i] <- word16Literals' args- -> reduce . Literal $ WordLiteral i- "GHC.Prim.plusWord16#" | Just r <- liftW16 plusWord16# args- -> reduce r- "GHC.Prim.subWord16#" | Just r <- liftW16 subWord16# args- -> reduce r- "GHC.Prim.timesWord16#" | Just r <- liftW16 timesWord16# args- -> reduce r- "GHC.Prim.quotWord16#" | Just r <- liftW16 quotWord16# args- -> reduce r- "GHC.Prim.remWord16#" | Just r <- liftW16 remWord16# args- -> reduce r- "GHC.Prim.quotRemWord16#"- | [i, j] <- word16Literals' args- , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty- , (Just tupTc) <- UniqMap.lookup tupTcNm tcm- , [tupDc] <- tyConDataCons tupTc- -> let !(W16# a) = fromInteger i- !(W16# b) = fromInteger j- !(# q, r #) = quotRemWord16# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Word16Literal (toInteger (W16# q))))- , Left (Literal (Word16Literal (toInteger (W16# r))))])- "GHC.Prim.andWord16#" | Just r <- liftW16 andWord16# args- -> reduce r- "GHC.Prim.orWord16#" | Just r <- liftW16 orWord16# args- -> reduce r- "GHC.Prim.xorWord16#" | Just r <- liftW16 xorWord16# args- -> reduce r- "GHC.Prim.notWord16#" | [i] <- word16Literals' args- -> let !(W16# a) = fromInteger i- in reduce (Literal (Word16Literal (toInteger (W16# (notWord16# a)))))- "GHC.Prim.uncheckedShiftLWord16#" | Just r <- liftW16I uncheckedShiftLWord16# args- -> reduce r- "GHC.Prim.uncheckedShiftRLWord16#" | Just r <- liftW16I uncheckedShiftRLWord16# args- -> reduce r- "GHC.Prim.word16ToInt16#" | [i] <- word16Literals' args- -> let !(W16# a) = fromInteger i- in reduce (Literal (Int16Literal (toInteger (I16# (word16ToInt16# a)))))- "GHC.Prim.eqWord16#" | Just r <- liftW16RI eqWord16# args- -> reduce r- "GHC.Prim.geWord16#" | Just r <- liftW16RI geWord16# args- -> reduce r- "GHC.Prim.gtWord16#" | Just r <- liftW16RI gtWord16# args- -> reduce r- "GHC.Prim.leWord16#" | Just r <- liftW16RI leWord16# args- -> reduce r- "GHC.Prim.ltWord16#" | Just r <- liftW16RI ltWord16# args- -> reduce r- "GHC.Prim.neWord16#" | Just r <- liftW16RI neWord16# args- -> reduce r--------------- Word32#------------ "GHC.Prim.wordToWord32#" | [i] <- wordLiterals' args- -> let !(W# a) = fromInteger i- b = narrow32Word# a- in reduce . Literal . Word32Literal . toInteger $ W# b- "GHC.Prim.word32ToWord#" | [i] <- word32Literals' args- -> reduce . Literal $ WordLiteral i- "GHC.Prim.plusWord32#" | Just r <- liftW32 plusWord32# args- -> reduce r- "GHC.Prim.subWord32#" | Just r <- liftW32 subWord32# args- -> reduce r- "GHC.Prim.timesWord32#" | Just r <- liftW32 timesWord32# args- -> reduce r- "GHC.Prim.quotWord32#" | Just r <- liftW32 quotWord32# args- -> reduce r- "GHC.Prim.remWord32#" | Just r <- liftW32 remWord32# args- -> reduce r- "GHC.Prim.quotRemWord32#"- | [i, j] <- word32Literals' args- , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty- , (Just tupTc) <- UniqMap.lookup tupTcNm tcm- , [tupDc] <- tyConDataCons tupTc- -> let !(W32# a) = fromInteger i- !(W32# b) = fromInteger j- !(# q, r #) = quotRemWord32# a b- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (Word32Literal (toInteger (W32# q))))- , Left (Literal (Word32Literal (toInteger (W32# r))))])- "GHC.Prim.andWord32#" | Just r <- liftW32 andWord32# args- -> reduce r- "GHC.Prim.orWord32#" | Just r <- liftW32 orWord32# args- -> reduce r- "GHC.Prim.xorWord32#" | Just r <- liftW32 xorWord32# args- -> reduce r- "GHC.Prim.notWord32#" | [i] <- word32Literals' args- -> let !(W32# a) = fromInteger i- in reduce (Literal (Word32Literal (toInteger (W32# (notWord32# a)))))- "GHC.Prim.uncheckedShiftLWord32#" | Just r <- liftW32I uncheckedShiftLWord32# args- -> reduce r- "GHC.Prim.uncheckedShiftRLWord32#" | Just r <- liftW32I uncheckedShiftRLWord32# args- -> reduce r- "GHC.Prim.word32ToInt32#" | [i] <- word32Literals' args- -> let !(W32# a) = fromInteger i- in reduce (Literal (Int32Literal (toInteger (I32# (word32ToInt32# a)))))- "GHC.Prim.eqWord32#" | Just r <- liftW32RI eqWord32# args- -> reduce r- "GHC.Prim.geWord32#" | Just r <- liftW32RI geWord32# args- -> reduce r- "GHC.Prim.gtWord32#" | Just r <- liftW32RI gtWord32# args- -> reduce r- "GHC.Prim.leWord32#" | Just r <- liftW32RI leWord32# args- -> reduce r- "GHC.Prim.ltWord32#" | Just r <- liftW32RI ltWord32# args- -> reduce r- "GHC.Prim.neWord32#" | Just r <- liftW32RI neWord32# args- -> reduce r--#if MIN_VERSION_base(4,17,0)-------------- Word64#------------ "GHC.Prim.wordToWord64#" | [i] <- wordLiterals' args- -> reduce (Literal (Word64Literal i))- "GHC.Prim.word64ToWord#" | [i] <- word64Literals' args- -> reduce . Literal $ WordLiteral i- "GHC.Prim.plusWord64#" | Just r <- liftW64 plusWord64# args- -> reduce r- "GHC.Prim.subWord64#" | Just r <- liftW64 subWord64# args- -> reduce r- "GHC.Prim.timesWord64#" | Just r <- liftW64 timesWord64# args- -> reduce r- "GHC.Prim.quotWord64#" | Just r <- liftW64 quotWord64# args- -> reduce r- "GHC.Prim.remWord64#" | Just r <- liftW64 remWord64# args- -> reduce r- "GHC.Prim.and64#" | Just r <- liftW64 and64# args- -> reduce r- "GHC.Prim.or64#" | Just r <- liftW64 or64# args- -> reduce r- "GHC.Prim.xor64#" | Just r <- liftW64 xor64# args- -> reduce r- "GHC.Prim.not64#" | [i] <- word64Literals' args- -> let !(W64# a) = fromInteger i- in reduce (Literal (Word64Literal (toInteger (W64# (not64# a)))))- "GHC.Prim.uncheckedShiftL64#" | Just r <- liftW64I uncheckedShiftL64# args- -> reduce r- "GHC.Prim.uncheckedShiftRL64#" | Just r <- liftW64I uncheckedShiftRL64# args- -> reduce r- "GHC.Prim.word64ToInt64#" | [i] <- word64Literals' args- -> let !(W64# a) = fromInteger i- in reduce (Literal (Int64Literal (toInteger (I64# (word64ToInt64# a)))))- "GHC.Prim.eqWord64#" | Just r <- liftW64RI eqWord64# args- -> reduce r- "GHC.Prim.geWord64#" | Just r <- liftW64RI geWord64# args- -> reduce r- "GHC.Prim.gtWord64#" | Just r <- liftW64RI gtWord64# args- -> reduce r- "GHC.Prim.leWord64#" | Just r <- liftW64RI leWord64# args- -> reduce r- "GHC.Prim.ltWord64#" | Just r <- liftW64RI ltWord64# args- -> reduce r- "GHC.Prim.neWord64#" | Just r <- liftW64RI neWord64# args- -> reduce r-#endif-#endif--------------- Double#------------ "GHC.Prim.>##" | Just r <- liftDDI (>##) args- -> reduce r- "GHC.Prim.>=##" | Just r <- liftDDI (>=##) args- -> reduce r- "GHC.Prim.==##" | Just r <- liftDDI (==##) args- -> reduce r- "GHC.Prim./=##" | Just r <- liftDDI (/=##) args- -> reduce r- "GHC.Prim.<##" | Just r <- liftDDI (<##) args- -> reduce r- "GHC.Prim.<=##" | Just r <- liftDDI (<=##) args- -> reduce r- "GHC.Prim.+##" | Just r <- liftDDD (+##) args- -> reduce r- "GHC.Prim.-##" | Just r <- liftDDD (-##) args- -> reduce r- "GHC.Prim.*##" | Just r <- liftDDD (*##) args- -> reduce r- "GHC.Prim./##" | Just r <- liftDDD (/##) args- -> reduce r-- "GHC.Prim.negateDouble#" | Just r <- liftDD negateDouble# args- -> reduce r- "GHC.Prim.fabsDouble#" | Just r <- liftDD fabsDouble# args- -> reduce r-- "GHC.Prim.double2Int#" | [i] <- doubleLiterals' args- -> let !(D# a) = wordToDouble i- r = double2Int# a- in reduce . Literal . IntLiteral . toInteger $ I# r- "GHC.Prim.double2Float#"- | [Lit (DoubleLiteral d)] <- args- -> let !(D# a) = wordToDouble d- r = double2Float# a- in reduce . Literal . FloatLiteral . floatToWord $ F# r-- "GHC.Prim.expDouble#" | Just r <- liftDD expDouble# args- -> reduce r- "GHC.Prim.logDouble#" | Just r <- liftDD logDouble# args- -> reduce r- "GHC.Prim.sqrtDouble#" | Just r <- liftDD sqrtDouble# args- -> reduce r- "GHC.Prim.sinDouble#" | Just r <- liftDD sinDouble# args- -> reduce r- "GHC.Prim.cosDouble#" | Just r <- liftDD cosDouble# args- -> reduce r- "GHC.Prim.tanDouble#" | Just r <- liftDD tanDouble# args- -> reduce r- "GHC.Prim.asinDouble#" | Just r <- liftDD asinDouble# args- -> reduce r- "GHC.Prim.acosDouble#" | Just r <- liftDD acosDouble# args- -> reduce r- "GHC.Prim.atanDouble#" | Just r <- liftDD atanDouble# args- -> reduce r- "GHC.Prim.sinhDouble#" | Just r <- liftDD sinhDouble# args- -> reduce r- "GHC.Prim.coshDouble#" | Just r <- liftDD coshDouble# args- -> reduce r- "GHC.Prim.tanhDouble#" | Just r <- liftDD tanhDouble# args- -> reduce r--#if MIN_VERSION_ghc(8,7,0)- "GHC.Prim.asinhDouble#" | Just r <- liftDD asinhDouble# args- -> reduce r- "GHC.Prim.acoshDouble#" | Just r <- liftDD acoshDouble# args- -> reduce r- "GHC.Prim.atanhDouble#" | Just r <- liftDD atanhDouble# args- -> reduce r-#endif-- "GHC.Prim.**##" | Just r <- liftDDD (**##) args- -> reduce r--- decodeDouble_2Int# :: Double# -> (#Int#, Word#, Word#, Int##)- "GHC.Prim.decodeDouble_2Int#" | [i] <- doubleLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = wordToDouble i- !(# p, q, r, s #) = decodeDouble_2Int# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# p)- , Left (Literal . WordLiteral . toInteger $ W# q)- , Left (Literal . WordLiteral . toInteger $ W# r)- , Left (Literal . IntLiteral . toInteger $ I# s)])--- decodeDouble_Int64# :: Double# -> (# Int64#, Int# #)- "GHC.Prim.decodeDouble_Int64#" | [i] <- doubleLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = wordToDouble i- !(# p, q #) = decodeDouble_Int64# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++-#if MIN_VERSION_ghc_prim(0,9,0)- [ Left (Literal . Int64Literal . toInteger $ I64# p)-#else- [ Left (Literal . IntLiteral . toInteger $ I64# p)-#endif- , Left (Literal . IntLiteral . toInteger $ I# q)])------------- Float---------- "GHC.Prim.gtFloat#" | Just r <- liftFFI gtFloat# args- -> reduce r- "GHC.Prim.geFloat#" | Just r <- liftFFI geFloat# args- -> reduce r- "GHC.Prim.eqFloat#" | Just r <- liftFFI eqFloat# args- -> reduce r- "GHC.Prim.neFloat#" | Just r <- liftFFI neFloat# args- -> reduce r- "GHC.Prim.ltFloat#" | Just r <- liftFFI ltFloat# args- -> reduce r- "GHC.Prim.leFloat#" | Just r <- liftFFI leFloat# args- -> reduce r-- "GHC.Prim.plusFloat#" | Just r <- liftFFF plusFloat# args- -> reduce r- "GHC.Prim.minusFloat#" | Just r <- liftFFF minusFloat# args- -> reduce r- "GHC.Prim.timesFloat#" | Just r <- liftFFF timesFloat# args- -> reduce r- "GHC.Prim.divideFloat#" | Just r <- liftFFF divideFloat# args- -> reduce r-- "GHC.Prim.negateFloat#" | Just r <- liftFF negateFloat# args- -> reduce r- "GHC.Prim.fabsFloat#" | Just r <- liftFF fabsFloat# args- -> reduce r-- "GHC.Prim.float2Int#" | [i] <- floatLiterals' args- -> let !(F# a) = wordToFloat i- r = float2Int# a- in reduce . Literal . IntLiteral . toInteger $ I# r-- "GHC.Prim.expFloat#" | Just r <- liftFF expFloat# args- -> reduce r- "GHC.Prim.logFloat#" | Just r <- liftFF logFloat# args- -> reduce r- "GHC.Prim.sqrtFloat#" | Just r <- liftFF sqrtFloat# args- -> reduce r- "GHC.Prim.sinFloat#" | Just r <- liftFF sinFloat# args- -> reduce r- "GHC.Prim.cosFloat#" | Just r <- liftFF cosFloat# args- -> reduce r- "GHC.Prim.tanFloat#" | Just r <- liftFF tanFloat# args- -> reduce r- "GHC.Prim.asinFloat#" | Just r <- liftFF asinFloat# args- -> reduce r- "GHC.Prim.acosFloat#" | Just r <- liftFF acosFloat# args- -> reduce r- "GHC.Prim.atanFloat#" | Just r <- liftFF atanFloat# args- -> reduce r- "GHC.Prim.sinhFloat#" | Just r <- liftFF sinhFloat# args- -> reduce r- "GHC.Prim.coshFloat#" | Just r <- liftFF coshFloat# args- -> reduce r- "GHC.Prim.tanhFloat#" | Just r <- liftFF tanhFloat# args- -> reduce r- "GHC.Prim.powerFloat#" | Just r <- liftFFF powerFloat# args- -> reduce r-- -- GHC.Float.asinh -- XXX: Very fragile- -- $w$casinh is the Double specialisation of asinh- -- $w$casinh1 is the Float specialisation of asinh- "GHC.Float.$w$casinh" | Just r <- liftDD go args- -> reduce r- where go f = case asinh (D# f) of- D# f' -> f'- "GHC.Float.$w$casinh1" | Just r <- liftFF go args- -> reduce r- where go f = case asinh (F# f) of- F# f' -> f'--#if MIN_VERSION_ghc(8,7,0)- "GHC.Prim.asinhFloat#" | Just r <- liftFF asinhFloat# args- -> reduce r- "GHC.Prim.acoshFloat#" | Just r <- liftFF acoshFloat# args- -> reduce r- "GHC.Prim.atanhFloat#" | Just r <- liftFF atanhFloat# args- -> reduce r-#endif-- "GHC.Prim.float2Double#" | [i] <- floatLiterals' args- -> let !(F# a) = wordToFloat i- r = float2Double# a- in reduce . Literal . DoubleLiteral . doubleToWord $ D# r--- "GHC.Prim.newByteArray#"- | [iV,PrimVal rwTy _ _] <- args- , [i] <- intLiterals' [iV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- p = primCount mach- lit = Literal (ByteArrayLiteral (fromList (List.genericReplicate i 0)))- mbaTy = mkFunTy intPrimTy (last tyArgs)- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left (mkApps (Prim (PrimInfo "GHC.Prim.MutableByteArray#" mbaTy WorkNever SingleResult NoUnfolding))- [Left (Literal . IntLiteral $ toInteger p)])- ])- in Just . setTerm newE $ primInsert p lit mach-- "GHC.Prim.setByteArray#"- | [PrimVal _mbaTy _ [baV]- ,offV,lenV,cV- ,PrimVal rwTy _ _- ] <- args- , [ba,off,len,c] <- intLiterals' [baV,offV,lenV,cV]- -> let Just (Literal (ByteArrayLiteral ba1)) =- primLookup (fromInteger ba) mach- !(I# off') = fromInteger off- !(I# len') = fromInteger len- !(I# c') = fromInteger c- ba2 = unsafeDupablePerformIO $ do- BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1- svoid (setByteArray# mba off' len' c')- BA.unsafeFreezeByteArray (BA.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral ba2)- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach-- "GHC.Prim.writeWordArray#"- | [PrimVal _mbaTy _ [baV]- ,iV,wV- ,PrimVal rwTy _ _- ] <- args- , [ba,i] <- intLiterals' [baV,iV]- , [w] <- wordLiterals' [wV]- -> let Just (Literal (ByteArrayLiteral ba1)) =- primLookup (fromInteger ba) mach- !(I# i') = fromInteger i- !(W# w') = fromIntegral w- ba2 = unsafeDupablePerformIO $ do- BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1- svoid (writeWordArray# mba i' w')- BA.unsafeFreezeByteArray (BA.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral ba2)- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach-- "GHC.Prim.unsafeFreezeByteArray#"- | [PrimVal _mbaTy _ [baV]- ,PrimVal rwTy _ _- ] <- args- , [ba] <- intLiterals' [baV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- Just ba' = primLookup (fromInteger ba) mach- in reduce $ mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left ba'])-- "GHC.Prim.sizeofByteArray#"- | [Lit (ByteArrayLiteral ba)] <- args- -> reduce (Literal (IntLiteral (toInteger (BA.sizeofByteArray ba))))-- "GHC.Prim.indexWordArray#"- | [Lit (ByteArrayLiteral (BA.ByteArray ba)),iV] <- args- , [i] <- intLiterals' [iV]- -> let !(I# i') = fromInteger i- !w = indexWordArray# ba i'- in reduce (Literal (WordLiteral (toInteger (W# w))))-- "GHC.Prim.getSizeofMutBigNat#"- | [PrimVal _mbaTy _ [baV]- ,PrimVal rwTy _ _- ] <- args- , [ba] <- intLiterals' [baV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- Just (Literal (ByteArrayLiteral ba')) = primLookup (fromInteger ba) mach- lit = Literal (IntLiteral (toInteger (BA.sizeofByteArray ba')))- in reduce $ mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left lit])-- "GHC.Prim.resizeMutableByteArray#"- | [PrimVal mbaTy _ [baV]- ,iV- ,PrimVal rwTy _ _- ] <- args- , [ba,i] <- intLiterals' [baV,iV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- p = primCount mach- Just (Literal (ByteArrayLiteral ba1))- = primLookup (fromInteger ba) mach- !(I# i') = fromInteger i- ba2 = unsafeDupablePerformIO $ do- BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1- mba' <- IO (\s -> case resizeMutableByteArray# mba i' s of- (# s', mba' #) -> (# s', BA.MutableByteArray mba' #))- BA.unsafeFreezeByteArray mba'- ba3 = Literal (ByteArrayLiteral ba2)- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left (mkApps (Prim mbaTy)- [Left (Literal . IntLiteral $ toInteger p)])- ])- in Just . setTerm newE $ primInsert p ba3 mach-- "GHC.Prim.shrinkMutableByteArray#"- | [PrimVal _mbaTy _ [baV]- ,lenV- ,PrimVal rwTy _ _- ] <- args- , [ba,len] <- intLiterals' [baV,lenV]- -> let Just (Literal (ByteArrayLiteral ba1)) =- primLookup (fromInteger ba) mach- !(I# len') = fromInteger len- ba2 = unsafeDupablePerformIO $ do- BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1- svoid (shrinkMutableByteArray# mba len')- BA.unsafeFreezeByteArray (BA.MutableByteArray mba)- ba3 = Literal (ByteArrayLiteral ba2)- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach-- "GHC.Prim.copyByteArray#"- | [Lit (ByteArrayLiteral (BA.ByteArray src_ba))- ,src_offV- ,PrimVal _mbaTy _ [dst_mbaV]- ,dst_offV, nV- ,PrimVal rwTy _ _- ] <- args- , [src_off,dst_mba,dst_off,n] <- intLiterals' [src_offV,dst_mbaV,dst_offV,nV]- -> let Just (Literal (ByteArrayLiteral dst_ba)) =- primLookup (fromInteger dst_mba) mach- !(I# src_off') = fromInteger src_off- !(I# dst_off') = fromInteger dst_off- !(I# n') = fromInteger n- ba2 = unsafeDupablePerformIO $ do- BA.MutableByteArray dst_mba1 <- BA.unsafeThawByteArray dst_ba- svoid (copyByteArray# src_ba src_off' dst_mba1 dst_off' n')- BA.unsafeFreezeByteArray (BA.MutableByteArray dst_mba1)- ba3 = Literal (ByteArrayLiteral ba2)- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger dst_mba) ba3 mach-- "GHC.Prim.readWordArray#"- | [PrimVal _mbaTy _ [baV]- ,offV- ,PrimVal rwTy _ _- ] <- args- , [ba,off] <- intLiterals' [baV,offV]- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- Just (Literal (ByteArrayLiteral ba1)) =- primLookup (fromInteger ba) mach- !(I# off') = fromInteger off- w = unsafeDupablePerformIO $ do- BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1- IO (\s -> case readWordArray# mba off' s of- (# s', w' #) -> (# s', W# w' #))- newE = mkApps (Data tupDc) (map Right tyArgs ++- [Left (Prim rwTy)- ,Left (Literal (WordLiteral (toInteger w)))- ])- in reduce newE-- "GHC.Prim.copyAddrToByteArray#"- | [ Lit (StringLiteral addr)- , PrimVal _mbaTy _ [dst_mbaV]- , offV, lenV- , PrimVal rwTy _ _- ] <- args- , [off,len,dst_mba] <- intLiterals' [offV, lenV, dst_mbaV]- -> let Just (Literal (ByteArrayLiteral dst_ba)) =- primLookup (fromInteger dst_mba) mach- !(I# off') = fromInteger off- !(I# len') = fromInteger len- !(BS.PS (ForeignPtr addr' _) _ _) = BS.packChars addr- ba2 = unsafeDupablePerformIO $ do- BA.MutableByteArray dst_mba1 <- BA.unsafeThawByteArray dst_ba- svoid (copyAddrToByteArray# addr' dst_mba1 off' len')- BA.unsafeFreezeByteArray (BA.MutableByteArray dst_mba1)- ba3 = Literal (ByteArrayLiteral ba2)- in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger dst_mba) ba3 mach---- decodeFloat_Int# :: Float# -> (#Int#, Int##)- "GHC.Prim.decodeFloat_Int#" | [i] <- floatLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(F# a) = wordToFloat i- !(# p, q #) = decodeFloat_Int# a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal . IntLiteral . toInteger $ I# p)- , Left (Literal . IntLiteral . toInteger $ I# q)])-- "GHC.Prim.tagToEnum#"- | [ConstTy (TyCon tcN)] <- tys- , [Lit (IntLiteral i)] <- args- -> let dc = do { tc <- UniqMap.lookup tcN tcm- ; let dcs = tyConDataCons tc- ; List.find ((== (i+1)) . toInteger . dcTag) dcs- }- in (\e -> setTerm (Data e) mach) <$> dc-- "GHC.Prim.dataToTag#"- | [DC dc _] <- args- -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))-- "GHC.Prim.dataToTagSmall#"- | [DC dc _] <- args- -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))-- "GHC.Prim.dataToTagLarge#"- | [DC dc _] <- args- -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))-- "GHC.Classes.eqInt" | Just (i,j) <- intCLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))-- "GHC.Classes.neInt" | Just (i,j) <- intCLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))-- "GHC.Classes.leInt" | Just (i,j) <- intCLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))-- "GHC.Classes.ltInt" | Just (i,j) <- intCLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))-- "GHC.Classes.geInt" | Just (i,j) <- intCLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))-- "GHC.Classes.gtInt" | Just (i,j) <- intCLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))-- "GHC.Classes.&&"- | [ lArg , rArg ] <- args- , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- -- evaluation of the arguments is deferred until the evaluation of the ghcPrimUnwindWith- -- to make `&&` lazy in both arguments- , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf eval tcm True (setTerm (valToTerm lArg) $ stackClear mach)- , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf eval tcm True (setTerm (valToTerm rArg) $ stackClear mach1)- -> case [ lArgWHNF, rArgWHNF ] of- [ Data lCon, Data rCon ] ->- Just $ mach2- { mStack = mStack mach- , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon && isTrueDC rCon)- }-- [ Data lCon, _ ]- | isTrueDC lCon -> reduce rArgWHNF- | otherwise -> reduce (boolToBoolLiteral tcm ty False)-- [ _, Data rCon ]- | isTrueDC rCon -> reduce lArgWHNF- | otherwise -> reduce (boolToBoolLiteral tcm ty False)-- _ -> Nothing-- "GHC.Classes.||"- | [ lArg , rArg ] <- args- , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- -- evaluation of the arguments is deferred until the evaluation of the ghcPrimUnwindWith- -- to make `||` lazy in both arguments- , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf eval tcm True (setTerm (valToTerm lArg) $ stackClear mach)- , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf eval tcm True (setTerm (valToTerm rArg) $ stackClear mach1)- -> case [ lArgWHNF, rArgWHNF ] of- [ Data lCon, Data rCon ] ->- Just $ mach2- { mStack = mStack mach- , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon || isTrueDC rCon)- }-- [ Data lCon, _ ]- | isFalseDC lCon -> reduce rArgWHNF- | otherwise -> reduce (boolToBoolLiteral tcm ty True)-- [ _, Data rCon ]- | isFalseDC rCon -> reduce lArgWHNF- | otherwise -> reduce (boolToBoolLiteral tcm ty True)-- _ -> Nothing-- "GHC.Classes.divInt#" | Just (i,j) <- intLiterals args- -> reduce (integerToIntLiteral (i `div` j))-- -- modInt# :: Int# -> Int# -> Int#- "GHC.Classes.modInt#"- | [dividend, divisor] <- intLiterals' args- ->- if divisor == 0 then- let iTy = snd (splitFunForallTy ty) in- reduce (TyApp (Prim NP.undefined) iTy)- else- reduce (Literal (IntLiteral (dividend `mod` divisor)))-- "GHC.Classes.not"- | [DC bCon _] <- args- -> reduce (boolToBoolLiteral tcm ty (nameOcc (dcName bCon) == "GHC.Types.False"))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerLogBase#"- | Just (a,b) <- integerLiterals args- , Just c <- flogBase a b- -> (reduce . Literal . WordLiteral . toInteger) c-- "GHC.Internal.Float.integerToFloat#"- | [v] <- args- , Just i <- integerLiteral v- -> reduce . Literal . FloatLiteral . floatToWord $ F# (integerToFloat# i)-- "GHC.Internal.Float.integerToDouble#"- | [v] <- args- , Just i <- integerLiteral v- -> reduce . Literal . DoubleLiteral . doubleToWord $ D# (integerToDouble# i)-- "GHC.Num.Integer.integerToFloat#"- | [v] <- args- , Just i <- integerLiteral v- -> reduce . Literal . FloatLiteral . floatToWord $ F# (integerToFloat# i)-- "GHC.Num.Integer.integerToDouble#"- | [v] <- args- , Just i <- integerLiteral v- -> reduce . Literal . DoubleLiteral . doubleToWord $ D# (integerToDouble# i)-- "GHC.Float.integerToFloat#"- | [v] <- args- , Just i <- integerLiteral v- -> reduce . Literal . FloatLiteral . floatToWord $ F# (integerToFloat# i)-- "GHC.Float.integerToDouble#"- | [v] <- args- , Just i <- integerLiteral v- -> reduce . Literal . DoubleLiteral . doubleToWord $ D# (integerToDouble# i)-- "GHC.Num.Natural.naturalLogBase#"- | Just (a,b) <- naturalLiterals args- , Just c <- flogBase a b- -> (reduce . Literal . WordLiteral . toInteger) c-#else- "GHC.Integer.Logarithms.integerLogBase#"- | Just (a,b) <- integerLiterals args- , Just c <- flogBase a b- -> (reduce . Literal . IntLiteral . toInteger) c-#endif--#if !MIN_VERSION_base(4,15,0)- "GHC.Integer.Type.smallInteger"- | [Lit (IntLiteral i)] <- args- -> reduce (Literal (IntegerLiteral i))-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerToInt#"-#else- "GHC.Integer.Type.integerToInt"-#endif- | [i] <- integerLiterals' args- -> reduce (integerToIntLiteral i)--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerDecodeDouble#" -- :: Double# -> (#Integer, Int##)-#else- "GHC.Integer.Type.decodeDoubleInteger" -- :: Double# -> (#Integer, Int##)-#endif- | [Lit (DoubleLiteral i)] <- args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- !(D# a) = wordToDouble i- !(# b, c #) = decodeDoubleInteger a- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (integerToIntegerLiteral b)- , Left (integerToIntLiteral . toInteger $ I# c)])--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerEncodeDouble#" -- :: Integer -> Int# -> Double-#else- "GHC.Integer.Type.encodeDoubleInteger" -- :: Integer -> Int# -> Double-#endif- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> let !(I# k') = fromInteger j- r = encodeDoubleInteger i k'- in reduce . Literal . DoubleLiteral . doubleToWord $ D# r--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerEncodeFloat#"- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> let !(I# k') = fromInteger j- r = integerEncodeFloat# i k'- in reduce . Literal . FloatLiteral . floatToWord $ F# r-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerQuotRem#" -- :: Integer -> Integer -> (#Integer, Integer#)-#else- "GHC.Integer.Type.quotRemInteger" -- :: Integer -> Integer -> (#Integer, Integer#)-#endif- | [i, j] <- integerLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem i j- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left $ catchDivByZero (integerToIntegerLiteral q)- , Left $ catchDivByZero (integerToIntegerLiteral r)])--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerAdd"-#else- "GHC.Integer.Type.plusInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i+j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerSub"-#else- "GHC.Integer.Type.minusInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i-j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerMul"-#else- "GHC.Integer.Type.timesInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (integerToIntegerLiteral (i*j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerNegate"-#else- "GHC.Integer.Type.negateInteger"-#endif- | [i] <- integerLiterals' args- -> reduce (integerToIntegerLiteral (negate i))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerDiv"-#else- "GHC.Integer.Type.divInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce $ catchDivByZero (integerToIntegerLiteral (i `div` j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerMod"-#else- "GHC.Integer.Type.modInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce $ catchDivByZero (integerToIntegerLiteral (i `mod` j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerQuot"-#else- "GHC.Integer.Type.quotInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce $ catchDivByZero (integerToIntegerLiteral (i `quot` j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerRem"-#else- "GHC.Integer.Type.remInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce $ catchDivByZero (integerToIntegerLiteral (i `rem` j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerDivMod#"-#else- "GHC.Integer.Type.divModInteger"-#endif- | Just (i,j) <- integerLiterals args- -> let (_,tyView -> TyConApp ubTupTcNm [liftedKi,_,intTy,_]) = splitFunForallTy ty- (Just ubTupTc) = UniqMap.lookup ubTupTcNm tcm- [ubTupDc] = tyConDataCons ubTupTc- (d,m) = divMod i j- in reduce $- mkApps (Data ubTupDc) [ Right liftedKi, Right liftedKi- , Right intTy, Right intTy- , Left $ catchDivByZero (Literal (IntegerLiteral d))- , Left $ catchDivByZero (Literal (IntegerLiteral m))- ]--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerGt"-#else- "GHC.Integer.Type.gtInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerGe"-#else- "GHC.Integer.Type.geInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerEq"-#else- "GHC.Integer.Type.eqInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerNe"-#else- "GHC.Integer.Type.neqInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerLt"-#else- "GHC.Integer.Type.ltInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerLe"-#else- "GHC.Integer.Type.leInteger"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerGt#"-#else- "GHC.Integer.Type.gtInteger#"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i > j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerGe#"-#else- "GHC.Integer.Type.geInteger#"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i >= j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerEq#"-#else- "GHC.Integer.Type.eqInteger#"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i == j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerNe#"-#else- "GHC.Integer.Type.neqInteger#"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i /= j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerLt#"-#else- "GHC.Integer.Type.ltInteger#"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i < j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerLe#"-#else- "GHC.Integer.Type.leInteger#"-#endif- | Just (i,j) <- integerLiterals args- -> reduce (boolToIntLiteral (i <= j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerCompare"-#else- "GHC.Integer.Type.compareInteger" -- :: Integer -> Integer -> Ordering-#endif- | [i, j] <- integerLiterals' args- -> let -- Get the required result type (viewed as an applied type constructor name)- (_,tyView -> TyConApp tupTcNm []) = splitFunForallTy ty- -- Find the type constructor from the name- (Just tupTc) = UniqMap.lookup tupTcNm tcm- -- Get the data constructors of that type- -- The type is 'Ordering', so they are: 'LT', 'EQ', 'GT'- [ltDc, eqDc, gtDc] = tyConDataCons tupTc- -- Do the actual compile-time evaluation- ordVal = compareInteger i j- in reduce $ case ordVal of- LT -> Data ltDc- EQ -> Data eqDc- GT -> Data gtDc--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerShiftR#"- | [iV, Lit (WordLiteral j)] <- args-#else- "GHC.Integer.Type.shiftRInteger"- | [iV, Lit (IntLiteral j)] <- args-#endif- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral (i `shiftR` fromInteger j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerShiftL#"- | [iV, Lit (WordLiteral j)] <- args-#else- "GHC.Integer.Type.shiftLInteger"- | [iV, Lit (IntLiteral j)] <- args-#endif- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral (i `shiftL` fromInteger j))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerFromWord#"-#else- "GHC.Integer.Type.wordToInteger"-#endif- | [Lit (WordLiteral w)] <- args- -> reduce (Literal (IntegerLiteral w))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerToWord#"-#else- "GHC.Integer.Type.integerToWord"-#endif- | [i] <- integerLiterals' args- -> reduce (integerToWordLiteral i)--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerTestBit#" -- :: Integer -> Int# -> Int#- | [Lit (IntegerLiteral i), Lit (WordLiteral j)] <- args- -> reduce (boolToIntLiteral (testBit i (fromInteger j)))-#else- "GHC.Integer.Type.testBitInteger" -- :: Integer -> Int# -> Bool- | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args- -> reduce (boolToBoolLiteral tcm ty (testBit i (fromInteger j)))-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.NS"- | [Lit (WordLiteral w)] <- args- -> reduce (Literal (NaturalLiteral w))- "GHC.Num.Natural.NB"- | [Lit (ByteArrayLiteral (BA.ByteArray ba))] <- args- -> reduce (Literal (NaturalLiteral (IP ba)))- | [Lit l] <- args- -> error ("NB: " <> show l)- "GHC.Num.Integer.IS"- | [Lit (IntLiteral i)] <- args- -> reduce (Literal (IntegerLiteral i))- "GHC.Num.Integer.IP"- | [Lit (ByteArrayLiteral (BA.ByteArray ba))] <- args- -> reduce (Literal (IntegerLiteral (IP ba)))- | [Lit l] <- args- -> error ("IP: " <> show l)- "GHC.Num.Integer.IN"- | [Lit (ByteArrayLiteral (BA.ByteArray ba))] <- args- -> reduce (Literal (IntegerLiteral (IN ba)))- | [Lit l] <- args- -> error ("IN: " <> show l)-#else- "GHC.Natural.NatS#"- | [Lit (WordLiteral w)] <- args- -> reduce (Literal (NaturalLiteral w))-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerFromNatural"-#else- "GHC.Natural.naturalToInteger"-#endif- | [i] <- naturalLiterals' args- -> reduce (Literal (IntegerLiteral (toInteger i)))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerToNatural"-#else- "GHC.Natural.naturalFromInteger"-#endif- | [i] <- integerLiterals' args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange1 nTy i id)--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerToNaturalClamp"- | [i] <- integerLiterals' args- -> if i < 0 then- reduce (naturalToNaturalLiteral 0)- else- reduce (naturalToNaturalLiteral (fromInteger i))-- "GHC.Num.Integer.integerToNaturalThrow"- | [i] <- integerLiterals' args- -> let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange1 nTy i id)-#endif-- "GHC.Num.Integer.integerToInt64#"- | [i] <- integerLiterals' args- -> reduce (integerToInt64Literal i)-- "GHC.Num.Integer.integerToWord64#"- | [i] <- integerLiterals' args- -> reduce (integerToWord64Literal i)--#if MIN_VERSION_base(4,17,0)- "GHC.Num.Integer.integerFromWord64#"- | [w] <- word64Literals' args- -> reduce (Literal (IntegerLiteral w))-#endif--#if !MIN_VERSION_base(4,15,0)- -- GHC.shiftLNatural --- XXX: Fragile worker of GHC.shiflLNatural- "GHC.Natural.$wshiftLNatural"- | [nV,iV] <- args- , [n] <- naturalLiterals' [nV]- , [i] <- fromInteger <$> intLiterals' [iV]- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange1 nTy n ((flip shiftL) i))-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalAdd"-#else- "GHC.Natural.plusNatural"-#endif- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j (+))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalMul"-#else- "GHC.Natural.timesNatural"-#endif- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j (*))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalSubUnsafe"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->- naturalToNaturalLiteral (naturalSubUnsafe i' j')))-- "GHC.Num.Natural.naturalSubThrow"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->- case minusNaturalMaybe i' j' of- Nothing -> checkNaturalRange1 nTy (-1) id- Just n -> naturalToNaturalLiteral n))-#else- "GHC.Natural.minusNatural"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->- case minusNaturalMaybe i' j' of- Nothing -> checkNaturalRange1 nTy (-1) id- Just n -> naturalToNaturalLiteral n))-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalFromWord#"-#else- "GHC.Natural.wordToNatural#"-#endif- | [Lit (WordLiteral w)] <- args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange1 nTy w id)--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalToWord#"- | [i] <- naturalLiterals' args- -> reduce (integerToWordLiteral i)-- "GHC.Num.Natural.naturalQuot"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j quot)-- "GHC.Num.Natural.naturalRem"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j rem)-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalQuotRem#" -- :: Natural -> Natural -> (#Natural, Natural#)- | [i, j] <- naturalLiterals' args- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- (q,r) = quotRem (fromInteger i) (fromInteger j)- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left $ catchDivByZero (naturalToNaturalLiteral q)- , Left $ catchDivByZero (naturalToNaturalLiteral r)])-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalGcd"-#else- "GHC.Natural.gcdNatural"-#endif- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j gcd)--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalLcm"- | Just (i,j) <- naturalLiterals args- ->- let nTy = snd (splitFunForallTy ty) in- reduce (checkNaturalRange2 nTy i j lcm)-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Natural.naturalGt#"- | Just (i,j) <- naturalLiterals args- -> reduce (boolToIntLiteral (i > j))-- "GHC.Num.Natural.naturalGe#"- | Just (i,j) <- naturalLiterals args- -> reduce (boolToIntLiteral (i >= j))-- "GHC.Num.Natural.naturalEq#"- | Just (i,j) <- naturalLiterals args- -> reduce (boolToIntLiteral (i == j))-- "GHC.Num.Natural.naturalNe#"- | Just (i,j) <- naturalLiterals args- -> reduce (boolToIntLiteral (i /= j))-- "GHC.Num.Natural.naturalLt#"- | Just (i,j) <- naturalLiterals args- -> reduce (boolToIntLiteral (i < j))-- "GHC.Num.Natural.naturalLe#"- | Just (i,j) <- naturalLiterals args- -> reduce (boolToIntLiteral (i <= j))-- "GHC.Num.Natural.naturalShiftL#"- | [iV, Lit (WordLiteral j)] <- args- , [i] <- naturalLiterals' [iV]- -> reduce (naturalToNaturalLiteral (fromInteger (i `shiftL` fromInteger j)))-- "GHC.Num.Natural.naturalShiftR#"- | [iV, Lit (WordLiteral j)] <- args- , [i] <- naturalLiterals' [iV]- -> reduce (naturalToNaturalLiteral (fromInteger (i `shiftR` fromInteger j)))-- "GHC.Num.Natural.naturalCompare"- | [i, j] <- naturalLiterals' args- -> let -- Get the required result type (viewed as an applied type constructor name)- (_,tyView -> TyConApp tupTcNm []) = splitFunForallTy ty- -- Find the type constructor from the name- (Just tupTc) = UniqMap.lookup tupTcNm tcm- -- Get the data constructors of that type- -- The type is 'Ordering', so they are: 'LT', 'EQ', 'GT'- [ltDc, eqDc, gtDc] = tyConDataCons tupTc- -- Do the actual compile-time evaluation- ordVal = compareInteger i j- in reduce $ case ordVal of- LT -> Data ltDc- EQ -> Data eqDc- GT -> Data gtDc-- "GHC.Num.Natural.naturalSignum"- | [i] <- naturalLiterals' args- -> reduce (Literal (NaturalLiteral (signum i)))-- "GHC.Num.Natural.$wnaturalSignum"- | [i] <- naturalLiterals' args- -> reduce (Literal (WordLiteral (signum i)))-#endif-- -- GHC.Real.^ -- XXX: Very fragile- -- ^_f, $wf, $wf1 are specialisations of the internal function f in the implementation of (^) in GHC.Real- "GHC.Real.^_f" -- :: Integer -> Integer -> Integer- | [i,j] <- integerLiterals' args- -> reduce (integerToIntegerLiteral $ i ^ j)- "GHC.Real.$wf" -- :: Integer -> Int# -> Integer- | [iV, Lit (IntLiteral j)] <- args- , [i] <- integerLiterals' [iV]- -> reduce (integerToIntegerLiteral $ i ^ j)- "GHC.Real.$wf1" -- :: Int# -> Int# -> Int#- | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args- -> reduce (integerToIntLiteral $ i ^ j)-- -- Type level ^ -- XXX: Very fragile- -- These is are specialized versions of ^_f, named by some combination of ghc and singletons.- "Data.Singletons.TypeLits.Internal.$fSingI->^@#@$_f" -- ghc-8.6.5, singletons-2.5.1- | [i,j] <- naturalLiterals' args- -> reduce (Literal (NaturalLiteral (i ^ j)))- "Data.Singletons.TypeLits.Internal.%^_f" -- ghc-8.8.1, singletons-2.6- | [i,j] <- naturalLiterals' args- -> reduce (Literal (NaturalLiteral (i ^ j)))-- "GHC.TypeLits.natVal"- | [Lit (NaturalLiteral n), _] <- args- -> reduce (integerToIntegerLiteral n)-- "GHC.TypeNats.natVal"- | [Lit (NaturalLiteral n), _] <- args- -> reduce (Literal (NaturalLiteral n))-- "GHC.TypeNats.someNatVal"- | [Lit (NaturalLiteral n)] <- args- -> let resTy = getResultTy tcm ty tys- in reduce (mkSomeNat tcm n resTy)-- "GHC.Internal.TypeNats.natVal"- | [Lit (NaturalLiteral n), _] <- args- -> reduce (Literal (NaturalLiteral n))-- "GHC.Internal.TypeNats.someNatVal"- | [Lit (NaturalLiteral n)] <- args- -> let resTy = getResultTy tcm ty tys- in reduce (mkSomeNat tcm n resTy)-- "GHC.Types.I#"- | isSubj- , [Lit (IntLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])-- "GHC.Int.I8#"- | isSubj-#if MIN_VERSION_base(4,16,0)- , [Lit (Int8Literal i)] <- args-#else- , [Lit (IntLiteral i)] <- args-#endif- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intDc] = tyConDataCons intTc-#if MIN_VERSION_base(4,16,0)- in reduce (mkApps (Data intDc) [Left (Literal (Int8Literal i))])-#else- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])-#endif- "GHC.Int.I16#"- | isSubj-#if MIN_VERSION_base(4,16,0)- , [Lit (Int16Literal i)] <- args-#else- , [Lit (IntLiteral i)] <- args-#endif- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intDc] = tyConDataCons intTc-#if MIN_VERSION_base(4,16,0)- in reduce (mkApps (Data intDc) [Left (Literal (Int16Literal i))])-#else- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])-#endif- "GHC.Int.I32#"- | isSubj-#if MIN_VERSION_base(4,16,0)- , [Lit (Int32Literal i)] <- args-#else- , [Lit (IntLiteral i)] <- args-#endif- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intDc] = tyConDataCons intTc-#if MIN_VERSION_base(4,16,0)- in reduce (mkApps (Data intDc) [Left (Literal (Int32Literal i))])-#else- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])-#endif- "GHC.Int.I64#"- | isSubj-#if MIN_VERSION_base(4,16,0)- , [Lit (Int64Literal i)] <- args-#else- , [Lit (IntLiteral i)] <- args-#endif- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intDc] = tyConDataCons intTc-#if MIN_VERSION_base(4,16,0)- in reduce (mkApps (Data intDc) [Left (Literal (Int64Literal i))])-#else- in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])-#endif-- "GHC.Word.W8#"- | isSubj-#if MIN_VERSION_base(4,16,0)- , [Lit (Word8Literal c)] <- args-#else- , [Lit (WordLiteral c)] <- args-#endif- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = UniqMap.lookup wordTcNm tcm- [wordDc] = tyConDataCons wordTc-#if MIN_VERSION_base(4,16,0)- in reduce (mkApps (Data wordDc) [Left (Literal (Word8Literal c))])-#else- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])-#endif- "GHC.Word.W16#"- | isSubj-#if MIN_VERSION_base(4,16,0)- , [Lit (Word16Literal c)] <- args-#else- , [Lit (WordLiteral c)] <- args-#endif- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = UniqMap.lookup wordTcNm tcm- [wordDc] = tyConDataCons wordTc-#if MIN_VERSION_base(4,16,0)- in reduce (mkApps (Data wordDc) [Left (Literal (Word16Literal c))])-#else- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])-#endif- "GHC.Word.W32#"- | isSubj-#if MIN_VERSION_base(4,16,0)- , [Lit (Word32Literal c)] <- args-#else- , [Lit (WordLiteral c)] <- args-#endif- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = UniqMap.lookup wordTcNm tcm- [wordDc] = tyConDataCons wordTc-#if MIN_VERSION_base(4,16,0)- in reduce (mkApps (Data wordDc) [Left (Literal (Word32Literal c))])-#else- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])-#endif- "GHC.Word.W64#"- | isSubj-#if MIN_VERSION_base(4,16,0)- , [Lit (Word64Literal c)] <- args-#else- , [Lit (WordLiteral c)] <- args-#endif- -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = UniqMap.lookup wordTcNm tcm- [wordDc] = tyConDataCons wordTc-#if MIN_VERSION_base(4,16,0)- in reduce (mkApps (Data wordDc) [Left (Literal (Word64Literal c))])-#else- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])-#endif-- "GHC.Types.W#"- | isSubj- , [Lit (WordLiteral i)] <- args- -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intDc] = tyConDataCons intTc- in reduce (mkApps (Data intDc) [Left (Literal (WordLiteral i))])-- "GHC.Float.$w$sfromRat''" -- XXX: Very fragile- | [Lit (IntLiteral _minEx)- ,Lit (IntLiteral matDigs)- ,nV- ,dV] <- args- , [n,d] <- integerLiterals' [nV,dV]- -> case fromInteger matDigs of- matDigs'- | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (floatToWord (fromRational (n :% d)))))- | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (doubleToWord (fromRational (n :% d)))))- _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"-- "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile- | [Lit (IntLiteral _minEx)- ,Lit (IntLiteral matDigs)- ,nV- ,dV] <- args- , [n,d] <- integerLiterals' [nV,dV]- -> case fromInteger matDigs of- matDigs'- | matDigs' == floatDigits (undefined :: Float)- -> reduce (Literal (FloatLiteral (floatToWord (fromRational (n :% d)))))- | matDigs' == floatDigits (undefined :: Double)- -> reduce (Literal (DoubleLiteral (doubleToWord (fromRational (n :% d)))))- _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerSignum#"-#else- "GHC.Integer.Type.$wsignumInteger" -- XXX: Not super-fragile, but still..-#endif- | [i] <- integerLiterals' args- -> reduce (Literal (IntLiteral (signum i)))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerSignum"-#else- "GHC.Integer.Type.signumInteger"-#endif- | [i] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (signumInteger i)))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.$wintegerSignum"- | [i] <- integerLiterals' args- -> reduce (Literal (IntLiteral (signum i)))-#endif--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerAbs"-#else- "GHC.Integer.Type.absInteger"-#endif- | [i] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (absInteger i)))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerBit#"- | [i] <- wordLiterals' args-#else- "GHC.Integer.Type.bitInteger"- | [i] <- intLiterals' args-#endif- -> reduce (Literal (IntegerLiteral (bit (fromInteger i))))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerComplement"-#else- "GHC.Integer.Type.complementInteger"-#endif- | [i] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (complementInteger i)))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerOr"-#else- "GHC.Integer.Type.orInteger"-#endif- | [i, j] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (orInteger i j)))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerXor"-#else- "GHC.Integer.Type.xorInteger"-#endif- | [i, j] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (xorInteger i j)))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerAnd"-#else- "GHC.Integer.Type.andInteger"-#endif- | [i, j] <- integerLiterals' args- -> reduce (Literal (IntegerLiteral (andInteger i j)))--#if MIN_VERSION_base(4,15,0)- "GHC.Num.Integer.integerToDouble#"-#else- "GHC.Integer.Type.doubleFromInteger"-#endif- | [i] <- integerLiterals' args- -> reduce (Literal (DoubleLiteral (doubleToWord (fromInteger i))))--#if MIN_VERSION_base(4,17,0)- "GHC.Num.Integer.$wintegerFromInt64#"- | [i] <- int64Literals' args- -> reduce . Literal $ IntLiteral i-#endif-- "GHC.Base.eqString"- | [PrimVal _ _ [Lit (StringLiteral s1)]- ,PrimVal _ _ [Lit (StringLiteral s2)]- ] <- args- -> reduce (boolToBoolLiteral tcm ty (s1 == s2))- | otherwise -> error (show args)-- "GHC.Base.quotInt"- | [ DC intDc [Left (Literal (IntLiteral i))]- , DC _ [Left (Literal (IntLiteral j))]- ] <- args- -> reduce (App (Data intDc) (Literal (IntLiteral (i `quot` j))))-- "GHC.Base.remInt"- | [ DC intDc [Left (Literal (IntLiteral i))]- , DC _ [Left (Literal (IntLiteral j))]- ] <- args- -> reduce (App (Data intDc) (Literal (IntLiteral (i `rem` j))))-- "GHC.Base.divInt"- | [ DC intDc [Left (Literal (IntLiteral i))]- , DC _ [Left (Literal (IntLiteral j))]- ] <- args- -> reduce (App (Data intDc) (Literal (IntLiteral (i `div` j))))--- "GHC.Base.modInt"- | [ DC intDc [Left (Literal (IntLiteral i))]- , DC _ [Left (Literal (IntLiteral j))]- ] <- args- -> reduce (App (Data intDc) (Literal (IntLiteral (i `mod` j))))-- "Clash.Class.BitPack.Internal.packDouble#" -- :: Double -> BitVector 64- | [DC _ [Left arg]] <- args- , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- , mach2@Machine{mStack=[],mTerm=Literal (DoubleLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)- -> let resTyInfo = extractTySizeInfo tcm ty tys- in Just $ mach2- { mStack = mStack mach- , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Word64 -> BitVector 64) i)- }-- "Clash.Class.BitPack.Internal.packFloat#" -- :: Float -> BitVector 32- | [DC _ [Left arg]] <- args- , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- , mach2@Machine{mStack=[],mTerm=Literal (FloatLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)- -> let resTyInfo = extractTySizeInfo tcm ty tys- in Just $ mach2- { mStack = mStack mach- , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Word32 -> BitVector 32) i)- }-- "Clash.Class.BitPack.Internal.unpackFloat#"- | [i] <- bitVectorLiterals' args- -> let resTy = getResultTy tcm ty tys- val = unpack (toBV i :: BitVector 32)- in reduce (mkFloatCLit tcm val resTy)-- "Clash.Class.BitPack.Internal.unpackDouble#"- | [i] <- bitVectorLiterals' args- -> let resTy = getResultTy tcm ty tys- val = unpack (toBV i :: BitVector 64)- in reduce (mkDoubleCLit tcm val resTy)-- "Clash.Sized.Internal.BitVector.xToBV"- | isSubj- , Just (nTy, kn) <- extractKnownNat tcm tys- -- The second argument to `xToBV` is always going to be suspended.- -- See Note [Lazy primitives]- , [ _, (Suspend arg) ] <- args- , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- , mach1@Machine{mStack=[],mTerm=argWHNF} <-- whnf eval tcm True (setTerm arg (stackClear mach))- , let undefBitVector =- Just $ mach1- { mStack = mStack mach- , mTerm = mkBitVectorLit ty nTy kn (bit (fromInteger kn)-1) 0- }- -> case isX argWHNF of- Left _ -> undefBitVector- _ -> case collectArgs argWHNF of- (Prim p,_) | primName p `elem` undefinedXPrims -> undefBitVector- _ -> Just $ mach1- { mStack = mStack mach- , mTerm = argWHNF- }-- -- expIndex#- -- :: KnownNat m- -- => Index m- -- -> SNat n- -- -> Index (n^m)- "Clash.Class.Exp.expIndex#"- | [b] <- indexLiterals' args- , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys- -> reduce (mkIndexLit ty (LitTy (NumTy (km^e))) (km^e) (b^e))-- -- expSigned#- -- :: KnownNat m- -- => Signed m- -- -> SNat n- -- -> Signed (n*m)- "Clash.Class.Exp.expSigned#"- | [b] <- signedLiterals' args- , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys- -> reduce (mkSignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))-- -- expUnsigned#- -- :: KnownNat m- -- => Unsigned m- -- -> SNat n- -- -> Unsigned m- "Clash.Class.Exp.expUnsigned#"- | [b] <- unsignedLiterals' args- , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys- -> reduce (mkUnsignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))-- "Clash.Promoted.Nat.powSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- -> let c = case a of- 2 -> 1 `shiftL` (fromInteger b)- _ -> a ^ b- (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = UniqMap.lookup snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c))- , Left (Literal (NaturalLiteral c))]-- "Clash.Promoted.Nat.flogBaseSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- flogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = UniqMap.lookup snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]-- "Clash.Promoted.Nat.clogBaseSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- clogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = UniqMap.lookup snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]- | otherwise- -> error ("clogBaseSNat: args = " <> show args <> ", tys = " <> show tys)-- "Clash.Promoted.Nat.logBaseSNat"- | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys- , Just c <- flogBase a b- , let c' = toInteger c- -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty- (Just snatTc) = UniqMap.lookup snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduce $- mkApps (Data snatDc) [ Right (LitTy (NumTy c'))- , Left (Literal (NaturalLiteral c'))]----------------- BitVector---------------- Constructor- "Clash.Sized.Internal.BitVector.BV"- | [Right _] <- map (runExcept . tyNatSize tcm) tys- , Just (m,i) <- integerLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo m i)-- "Clash.Sized.Internal.BitVector.Bit"- | Just (m,i) <- integerLiterals args- -> reduce (mkBitLit ty m i)---- Initialisation- "Clash.Sized.Internal.BitVector.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])- "Clash.Sized.Internal.BitVector.maxIndex#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (kn-1)))])---- Construction- "Clash.Sized.Internal.BitVector.high"- -> reduce (mkBitLit ty 0 1)- "Clash.Sized.Internal.BitVector.low"- -> reduce (mkBitLit ty 0 0)-- "Clash.Sized.Internal.BitVector.undefined#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let resTyInfo = extractTySizeInfo tcm ty tys- mask = bit (fromInteger kn) - 1- in reduce (mkBitVectorLit' resTyInfo mask 0)---- Eq- "Clash.Sized.Internal.BitVector.eq##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.BitVector.neq##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.BitVector.lt##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.BitVector.ge##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.BitVector.gt##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.BitVector.le##" | [(0,i),(0,j)] <- bitLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Enum- "Clash.Sized.Internal.BitVector.toEnum##"- | [i] <- intCLiterals' args- -> let Bit msk val = BitVector.toEnum## (fromInteger i)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))---- Bits- "Clash.Sized.Internal.BitVector.and##"- | [i,j] <- bitLiterals args- -> let Bit msk val = BitVector.and## (toBit i) (toBit j)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))- "Clash.Sized.Internal.BitVector.or##"- | [i,j] <- bitLiterals args- -> let Bit msk val = BitVector.or## (toBit i) (toBit j)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))- "Clash.Sized.Internal.BitVector.xor##"- | [i,j] <- bitLiterals args- -> let Bit msk val = BitVector.xor## (toBit i) (toBit j)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))-- "Clash.Sized.Internal.BitVector.complement##"- | [i] <- bitLiterals args- -> let Bit msk val = BitVector.complement## (toBit i)- in reduce (mkBitLit ty (toInteger msk) (toInteger val))---- Pack- "Clash.Sized.Internal.BitVector.pack#"- | [(msk,i)] <- bitLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo msk i)-- "Clash.Sized.Internal.BitVector.unpack#"- | [(msk,i)] <- bitVectorLiterals' args- -> reduce (mkBitLit ty msk i)---- Concatenation- "Clash.Sized.Internal.BitVector.++#" -- :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)- | Just (_,m) <- extractKnownNat tcm tys- , [(mski,i),(mskj,j)] <- bitVectorLiterals' args- -> let val = i `shiftL` fromInteger m .|. j- msk = mski `shiftL` fromInteger m .|. mskj- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo msk val)---- Reduction- "Clash.Sized.Internal.BitVector.reduceAnd#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy 0 val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceAnd# u)- "Clash.Sized.Internal.BitVector.reduceOr#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy 0 val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceOr# u)- "Clash.Sized.Internal.BitVector.reduceXor#" -- :: KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- val = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy 0 val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (BitVector.reduceXor# u)----- Indexing- "Clash.Sized.Internal.BitVector.index#" -- :: KnownNat n => BitVector n -> Int -> Bit- | Just (_,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let resTy = getResultTy tcm ty tys- (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitLit resTy msk val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = (toInteger m, toInteger v)- where Bit m v = (BitVector.index# u i)- "Clash.Sized.Internal.BitVector.replaceBit#" -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n- | Just (_, n) <- extractKnownNat tcm tys- , [ _- , PrimVal bvP _ [_, Lit (NaturalLiteral mskBv), Lit (IntegerLiteral bv)]- , valArgs -> Just [Literal (IntLiteral i)]- , PrimVal bP _ [Lit (WordLiteral mskB), Lit (IntegerLiteral b)]- ] <- args- , primName bvP == "Clash.Sized.Internal.BitVector.fromInteger#"- , primName bP == "Clash.Sized.Internal.BitVector.fromInteger##"- -> let resTyInfo = extractTySizeInfo tcm ty tys- (mskVal,val) = reifyNat n (op (BV (fromInteger mskBv) (fromInteger bv))- (fromInteger i)- (Bit (fromInteger mskB) (fromInteger b)))- in reduce (mkBitVectorLit' resTyInfo mskVal val)- where- op :: KnownNat n => BitVector n -> Int -> Bit -> Proxy n -> (Integer,Integer)- -- op bv i b _ = (BitVector.unsafeMask res, BitVector.unsafeToInteger res)- op bv i b _ = splitBV (BitVector.replaceBit# bv i b)- "Clash.Sized.Internal.BitVector.setSlice#"- -- :: SNat (m+1+i) -> BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) -> BitVector (m + 1 + i)- | mTy : iTy : nTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- , Right iN <- runExcept (tyNatSize tcm iTy)- , Right n <- runExcept (tyNatSize tcm nTy)- , [i,j] <- bitVectorLiterals' args- -> let BV msk val = BitVector.setSlice# (unsafeSNat (m+1+iN)) (toBV i) (unsafeSNat m) (unsafeSNat n) (toBV j)- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))- "Clash.Sized.Internal.BitVector.slice#"- -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)- | mTy : _ : nTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- , Right n <- runExcept (tyNatSize tcm nTy)- , [i] <- bitVectorLiterals' args- -> let BV msk val = BitVector.slice# (toBV i) (unsafeSNat m) (unsafeSNat n)- resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))- "Clash.Sized.Internal.BitVector.split#" -- :: forall n m. KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n)- | nTy : mTy : _ <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- , [(mski,i)] <- bitVectorLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty'- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- bvTy : _ = tyArgs- valM = i `shiftR` fromInteger n- mskM = mski `shiftR` fromInteger n- valN = i .&. mask- mskN = mski .&. mask- mask = bit (fromInteger n) - 1- in reduce $- mkApps (Data tupDc) (map Right tyArgs ++- [ Left (mkBitVectorLit bvTy mTy m mskM valM)- , Left (mkBitVectorLit bvTy nTy n mskN valN)])-- "Clash.Sized.Internal.BitVector.msb#" -- :: forall n. KnownNat n => BitVector n -> Bit- | [i] <- bitVectorLiterals' args- , Just (_, kn) <- extractKnownNat tcm tys- -> let resTy = getResultTy tcm ty tys- (msk,val) = reifyNat kn (op (toBV i))- in reduce (mkBitLit resTy (toInteger msk) (toInteger val))- where- op :: KnownNat n => BitVector n -> Proxy n -> (Word,Word)- op u _ = (unsafeMask# res, BitVector.unsafeToInteger# res)- where- res = BitVector.msb# u- "Clash.Sized.Internal.BitVector.lsb#" -- :: BitVector n -> Bit- | [i] <- bitVectorLiterals' args- -> let resTy = getResultTy tcm ty tys- Bit msk val = BitVector.lsb# (toBV i)- in reduce (mkBitLit resTy (toInteger msk) (toInteger val))----- Eq- -- eq#, neq# :: KnownNat n => BitVector n -> BitVector n -> Bool- "Clash.Sized.Internal.BitVector.eq#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty True)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.eq# ty tcm args)- -> reduce val-- "Clash.Sized.Internal.BitVector.neq#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty False)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.neq# ty tcm args)- -> reduce val---- Ord- -- lt#,ge#,gt#,le# :: KnownNat n => BitVector n -> BitVector n -> Bool- "Clash.Sized.Internal.BitVector.lt#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty False)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.lt# ty tcm args)- -> reduce val- "Clash.Sized.Internal.BitVector.ge#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty True)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.ge# ty tcm args)- -> reduce val- "Clash.Sized.Internal.BitVector.gt#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty False)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.gt# ty tcm args)- -> reduce val- "Clash.Sized.Internal.BitVector.le#"- | nTy : _ <- tys- , Right 0 <- runExcept (tyNatSize tcm nTy)- -> reduce (boolToBoolLiteral tcm ty True)- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2Bool BitVector.le# ty tcm args)- -> reduce val---- Enum-- "Clash.Sized.Internal.BitVector.toEnum#"- | let resTyInfo@(_,_,kn) = extractTySizeInfo tcm ty tys- , Just val <- reifyNat kn (liftInteger2BitVector (BitVector.toEnum# . fromInteger) resTyInfo args)- -> reduce val-- "Clash.Sized.Internal.BitVector.fromEnum#"- | Just (_, kn) <- extractKnownNat tcm tys- , let resTy = getResultTy tcm ty tys- , Just val <- reifyNat kn (liftBitVector2CInt tcm resTy (toInteger . BitVector.fromEnum#) args)- -> reduce val---- Bounded- "Clash.Sized.Internal.BitVector.minBound#"- | Just (nTy,len) <- extractKnownNat tcm tys- -> reduce (mkBitVectorLit ty nTy len 0 0)- "Clash.Sized.Internal.BitVector.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ mb) - 1- in reduce (mkBitVectorLit ty litTy mb 0 maxB)---- Num- "Clash.Sized.Internal.BitVector.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.+#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.-#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.*#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> let (msk,val) = reifyNat kn (op (toBV i))- in reduce (mkBitVectorLit ty nTy kn msk val)- where- op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)- op u _ = splitBV (BitVector.negate# u)---- ExtendingNum- "Clash.Sized.Internal.BitVector.plus#" -- :: (KnownNat n, KnownNat m) => BitVector m -> BitVector n -> BitVector (Max m n + 1)- | [(0,i),(0,j)] <- bitVectorLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i+j))-- "Clash.Sized.Internal.BitVector.minus#"- | [(0,i),(0,j)] <- bitVectorLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- val = reifyNat resSizeInt (runSizedF (BitVector.-#) i j)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 val)-- "Clash.Sized.Internal.BitVector.times#"- | [(0,i),(0,j)] <- bitVectorLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i*j))---- Integral- "Clash.Sized.Internal.BitVector.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.quot#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.BitVector.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.rem#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.BitVector.toInteger#"- | Just (_, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> let val = reifyNat kn (op (toBV i))- in reduce (integerToIntegerLiteral val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = BitVector.toInteger# u---- Bits- "Clash.Sized.Internal.BitVector.and#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.and#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.or#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.or#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.BitVector.xor#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftBitVector2 (BitVector.xor#) ty tcm tys args)- -> reduce val-- "Clash.Sized.Internal.BitVector.complement#"- | [i] <- bitVectorLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let (msk,val) = reifyNat kn (op (toBV i))- in reduce (mkBitVectorLit ty nTy kn msk val)- where- op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)- op u _ = splitBV $ BitVector.complement# u-- "Clash.Sized.Internal.BitVector.shiftL#"- | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn msk val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = splitBV (BitVector.shiftL# u i)- "Clash.Sized.Internal.BitVector.shiftR#"- | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn msk val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = splitBV (BitVector.shiftR# u i)- "Clash.Sized.Internal.BitVector.rotateL#"- | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn msk val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = splitBV (BitVector.rotateL# u i)- "Clash.Sized.Internal.BitVector.rotateR#"- | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args- -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))- in reduce (mkBitVectorLit ty nTy kn msk val)- where- op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)- op u i _ = splitBV (BitVector.rotateR# u i)---- truncateB- "Clash.Sized.Internal.BitVector.truncateB#" -- forall a b . KnownNat a => BitVector (a + b) -> BitVector a- | aTy : _ <- tys- , Right ka <- runExcept (tyNatSize tcm aTy)- , [(mski,i)] <- bitVectorLiterals' args- -> let bitsKeep = (bit (fromInteger ka)) - 1- val = i .&. bitsKeep- msk = mski .&. bitsKeep- in reduce (mkBitVectorLit ty aTy ka msk val)------------- Index------------ BitPack- "Clash.Sized.Internal.Index.pack#"- | nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm nTy)- , [i] <- indexLiterals' args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo 0 i)- "Clash.Sized.Internal.Index.unpack#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [(0,i)] <- bitVectorLiterals' args- -> reduce (mkIndexLit ty nTy kn i)---- Eq- "Clash.Sized.Internal.Index.eq#" | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Index.neq#" | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Index.lt#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Index.ge#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Index.gt#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Index.le#"- | Just (i,j) <- indexLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Enum- "Clash.Sized.Internal.Index.toEnum#"- | [i] <- intCLiterals' args- , Just (nTy, mb) <- extractKnownNat tcm tys- -> reduce (mkIndexLit ty nTy mb i)-- "Clash.Sized.Internal.Index.fromEnum#"- | [i] <- indexLiterals' args- -> let resTy = getResultTy tcm ty tys- in reduce (mkIntCLit tcm i resTy)---- Bounded- "Clash.Sized.Internal.Index.maxBound#"- | Just (nTy,mb) <- extractKnownNat tcm tys- -> reduce (mkIndexLit ty nTy mb (mb - 1))---- Num- "Clash.Sized.Internal.Index.+#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> reduce (mkIndexLit ty nTy kn (i + j))- "Clash.Sized.Internal.Index.-#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> reduce (mkIndexLit ty nTy kn (i - j))- "Clash.Sized.Internal.Index.*#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , [i,j] <- indexLiterals' args- -> reduce (mkIndexLit ty nTy kn (i * j))---- ExtendingNum- "Clash.Sized.Internal.Index.plus#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkIndexLit' resTyInfo (i + j))- "Clash.Sized.Internal.Index.minus#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkIndexLit' resTyInfo (i - j))- "Clash.Sized.Internal.Index.times#"- | mTy : nTy : _ <- tys- , Right _ <- runExcept (tyNatSize tcm mTy)- , Right _ <- runExcept (tyNatSize tcm nTy)- , Just (i,j) <- indexLiterals args- -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkIndexLit' resTyInfo (i * j))---- Integral- "Clash.Sized.Internal.Index.quot#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , Just (i,j) <- indexLiterals args- -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `quot` j))- "Clash.Sized.Internal.Index.rem#"- | Just (nTy,kn) <- extractKnownNat tcm tys- , Just (i,j) <- indexLiterals args- -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `rem` j))- "Clash.Sized.Internal.Index.toInteger#"- | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args- , primName p == "Clash.Sized.Internal.Index.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Resize- "Clash.Sized.Internal.Index.resize#"- | Just (mTy,m) <- extractKnownNat tcm tys- , [i] <- indexLiterals' args- -> reduce (mkIndexLit ty mTy m i)-------------- Signed----------- "Clash.Sized.Internal.Signed.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])---- BitPack- "Clash.Sized.Internal.Signed.pack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkBitVectorLit ty nTy kn 0 val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op s _ = toInteger (Signed.pack# s)- "Clash.Sized.Internal.Signed.unpack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [(0,i)] <- bitVectorLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op s _ = toInteger (Signed.unpack# s)---- Eq- "Clash.Sized.Internal.Signed.eq#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Signed.neq#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Signed.lt#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Signed.ge#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Signed.gt#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Signed.le#" | Just (i,j) <- signedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Enum- "Clash.Sized.Internal.Signed.toEnum#"- | [i] <- intCLiterals' args- , Just (litTy, mb) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty litTy mb i)-- "Clash.Sized.Internal.Signed.fromEnum#"- | [i] <- signedLiterals' args- -> let resTy = getResultTy tcm ty tys- in reduce (mkIntCLit tcm i resTy)---- Bounded- "Clash.Sized.Internal.Signed.minBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let minB = negate (2 ^ (mb - 1))- in reduce (mkSignedLit ty litTy mb minB)- "Clash.Sized.Internal.Signed.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ (mb - 1)) - 1- in reduce (mkSignedLit ty litTy mb maxB)---- Num- "Clash.Sized.Internal.Signed.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.+#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.-#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.*#) ty tcm tys args)- -> reduce (val)- "Clash.Sized.Internal.Signed.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op s _ = toInteger (Signed.negate# s)- "Clash.Sized.Internal.Signed.abs#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op s _ = toInteger (Signed.abs# s)---- ExtendingNum- "Clash.Sized.Internal.Signed.plus#"- | Just (i,j) <- signedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i+j))-- "Clash.Sized.Internal.Signed.minus#"- | Just (i,j) <- signedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i-j))-- "Clash.Sized.Internal.Signed.times#"- | Just (i,j) <- signedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkSignedLit resTy resSizeTy resSizeInt (i*j))---- Integral- "Clash.Sized.Internal.Signed.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.quot#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Signed.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.rem#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Signed.div#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.div#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Signed.mod#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftSigned2 (Signed.mod#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Signed.toInteger#"- | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args- , primName p == "Clash.Sized.Internal.Signed.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Bits- "Clash.Sized.Internal.Signed.and#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i .&. j))- "Clash.Sized.Internal.Signed.or#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i .|. j))- "Clash.Sized.Internal.Signed.xor#"- | [i,j] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkSignedLit ty nTy kn (i `xor` j))-- "Clash.Sized.Internal.Signed.complement#"- | [i] <- signedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Proxy n -> Integer- op u _ = toInteger (Signed.complement# u)-- "Clash.Sized.Internal.Signed.shiftL#"- | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.shiftL# u i)- "Clash.Sized.Internal.Signed.shiftR#"- | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.shiftR# u i)- "Clash.Sized.Internal.Signed.rotateL#"- | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.rotateL# u i)- "Clash.Sized.Internal.Signed.rotateR#"- | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkSignedLit ty nTy kn val)- where- op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Signed.rotateR# u i)---- Resize- "Clash.Sized.Internal.Signed.resize#" -- forall m n. (KnownNat n, KnownNat m) => Signed n -> Signed m- | mTy : nTy : _ <- tys- , Right mInt <- runExcept (tyNatSize tcm mTy)- , Right nInt <- runExcept (tyNatSize tcm nTy)- , [i] <- signedLiterals' args- -> let val | nInt <= mInt = extended- | otherwise = truncated- extended = i- mask = 1 `shiftL` fromInteger (mInt - 1)- i' = i `mod` mask- truncated = if testBit i (fromInteger nInt - 1)- then (i' - mask)- else i'- in reduce (mkSignedLit ty mTy mInt val)- "Clash.Sized.Internal.Signed.truncateB#" -- KnownNat m => Signed (m + n) -> Signed m- | Just (mTy, km) <- extractKnownNat tcm tys- , [i] <- signedLiterals' args- -> let bitsKeep = (bit (fromInteger km)) - 1- val = i .&. bitsKeep- in reduce (mkSignedLit ty mTy km val)---- SaturatingNum--- No need to manually evaluate Clash.Sized.Internal.Signed.minBoundSym#--- It is just implemented in terms of other primitives.----------------- Unsigned------------- "Clash.Sized.Internal.Unsigned.size#"- | Just (_, kn) <- extractKnownNat tcm tys- -> let (_,ty') = splitFunForallTy ty- (TyConApp intTcNm _) = tyView ty'- (Just intTc) = UniqMap.lookup intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])---- BitPack- "Clash.Sized.Internal.Unsigned.pack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- unsignedLiterals' args- -> reduce (mkBitVectorLit ty nTy kn 0 i)- "Clash.Sized.Internal.Unsigned.unpack#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- bitVectorLiterals' args- -> let val = reifyNat kn (op (toBV i))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => BitVector n -> Proxy n -> Integer- op u _ = toInteger (Unsigned.unpack# u)---- Eq- "Clash.Sized.Internal.Unsigned.eq#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i == j))- "Clash.Sized.Internal.Unsigned.neq#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i /= j))---- Ord- "Clash.Sized.Internal.Unsigned.lt#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i < j))- "Clash.Sized.Internal.Unsigned.ge#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i >= j))- "Clash.Sized.Internal.Unsigned.gt#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i > j))- "Clash.Sized.Internal.Unsigned.le#" | Just (i,j) <- unsignedLiterals args- -> reduce (boolToBoolLiteral tcm ty (i <= j))---- Enum- "Clash.Sized.Internal.Unsigned.toEnum#"- | [i] <- intCLiterals' args- , Just (litTy, mb) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty litTy mb i)-- "Clash.Sized.Internal.Unsigned.fromEnum#"- | [i] <- unsignedLiterals' args- -> let resTy = getResultTy tcm ty tys- in reduce (mkIntCLit tcm i resTy)---- Bounded- "Clash.Sized.Internal.Unsigned.minBound#"- | Just (nTy,len) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy len 0)- "Clash.Sized.Internal.Unsigned.maxBound#"- | Just (litTy,mb) <- extractKnownNat tcm tys- -> let maxB = (2 ^ mb) - 1- in reduce (mkUnsignedLit ty litTy mb maxB)---- Num- "Clash.Sized.Internal.Unsigned.+#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.+#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.-#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.-#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.*#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.*#) ty tcm tys args)- -> reduce val- "Clash.Sized.Internal.Unsigned.negate#"- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i] <- unsignedLiterals' args- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Proxy n -> Integer- op u _ = toInteger (Unsigned.negate# u)---- ExtendingNum- "Clash.Sized.Internal.Unsigned.plus#" -- :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)- | Just (i,j) <- unsignedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i+j))-- "Clash.Sized.Internal.Unsigned.minus#"- | [i,j] <- unsignedLiterals' args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- val = reifyNat resSizeInt (runSizedF (Unsigned.-#) i j)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt val)-- "Clash.Sized.Internal.Unsigned.times#"- | Just (i,j) <- unsignedLiterals args- -> let ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- (TyConApp _ [resSizeTy]) = tyView resTy- Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)- in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i*j))---- Integral- "Clash.Sized.Internal.Unsigned.quot#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.quot#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Unsigned.rem#"- | Just (_, kn) <- extractKnownNat tcm tys- , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.rem#) ty tcm tys args)- -> reduce $ catchDivByZero val- "Clash.Sized.Internal.Unsigned.toInteger#"- | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args- , primName p == "Clash.Sized.Internal.Unsigned.fromInteger#"- -> reduce (integerToIntegerLiteral i)---- Bits- "Clash.Sized.Internal.Unsigned.and#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i .&. j))- "Clash.Sized.Internal.Unsigned.or#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i .|. j))- "Clash.Sized.Internal.Unsigned.xor#"- | Just (i,j) <- unsignedLiterals args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> reduce (mkUnsignedLit ty nTy kn (i `xor` j))-- "Clash.Sized.Internal.Unsigned.complement#"- | [i] <- unsignedLiterals' args- , Just (nTy, kn) <- extractKnownNat tcm tys- -> let val = reifyNat kn (op (fromInteger i))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Proxy n -> Integer- op u _ = toInteger (Unsigned.complement# u)-- "Clash.Sized.Internal.Unsigned.shiftL#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n- | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.shiftL# u i)- "Clash.Sized.Internal.Unsigned.shiftR#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n- | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.shiftR# u i)- "Clash.Sized.Internal.Unsigned.rotateL#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n- | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.rotateL# u i)- "Clash.Sized.Internal.Unsigned.rotateR#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n- | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args- -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))- in reduce (mkUnsignedLit ty nTy kn val)- where- op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer- op u i _ = toInteger (Unsigned.rotateR# u i)---- Resize- "Clash.Sized.Internal.Unsigned.resize#" -- forall n m . KnownNat m => Unsigned n -> Unsigned m- | _ : mTy : _ <- tys- , Right km <- runExcept (tyNatSize tcm mTy)- , [i] <- unsignedLiterals' args- -> let bitsKeep = (bit (fromInteger km)) - 1- val = i .&. bitsKeep- in reduce (mkUnsignedLit ty mTy km val)---- Conversions- "Clash.Sized.Internal.Unsigned.unsignedToWord"- | isSubj- , [a] <- unsignedLiterals' args- -> let b = Unsigned.unsignedToWord (U (fromInteger a))- (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = UniqMap.lookup wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])-- "Clash.Sized.Internal.Unsigned.unsigned8toWord8"- | isSubj- , [a] <- unsignedLiterals' args- -> let b = Unsigned.unsigned8toWord8 (U (fromInteger a))- (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = UniqMap.lookup wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])-- "Clash.Sized.Internal.Unsigned.unsigned16toWord16"- | isSubj- , [a] <- unsignedLiterals' args- -> let b = Unsigned.unsigned16toWord16 (U (fromInteger a))- (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = UniqMap.lookup wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])-- "Clash.Sized.Internal.Unsigned.unsigned32toWord32"- | isSubj- , [a] <- unsignedLiterals' args- -> let b = Unsigned.unsigned32toWord32 (U (fromInteger a))- (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty- (Just wordTc) = UniqMap.lookup wordTcNm tcm- [wordDc] = tyConDataCons wordTc- in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])-- "Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL"- | isSubj- , f : a : _ <- args- -> reduceWHNF (mkApps (valToTerm f) [Left (valToTerm a)])------------- RTree---------- "Clash.Sized.RTree.textract"- | isSubj- , [DC _ tArgs] <- args- -> reduceWHNF (Either.lefts tArgs !! 1)-- "Clash.Sized.RTree.tsplit"- | isSubj- , dTy : aTy : _ <- tys- , [DC _ tArgs] <- args- , (tyArgs,tyView -> TyConApp tupTcNm _) <- splitFunForallTy ty- , TyConApp treeTcNm _ <- tyView (Either.rights tyArgs !! 0)- -> let (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- in reduce $- mkApps (Data tupDc)- [Right (mkTyConApp treeTcNm [dTy,aTy])- ,Right (mkTyConApp treeTcNm [dTy,aTy])- ,Left (Either.lefts tArgs !! 1)- ,Left (Either.lefts tArgs !! 2)- ]-- "Clash.Sized.RTree.tdfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : g : ts : _ <- args- , DC _ tArgs <- ts- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts tArgs !! 1)])- _ -> let k'ty = LitTy (NumTy (k'-1))- (tyArgs,_) = splitFunForallTy ty- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = UniqMap.lookup snatTcNm tcm- [snatDc] = tyConDataCons snatTc- in reduceWHNF $- mkApps (valToTerm g)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Either.lefts tArgs !! 1)- ])- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Either.lefts tArgs !! 2)- ])- ]-- "Clash.Sized.RTree.treplicate"- | isSubj- , let ty' = piResultTys tcm ty tys- , (_,tyView -> TyConApp treeTcNm [lenTy,argTy]) <- splitFunForallTy ty'- , Right len <- runExcept (tyNatSize tcm lenTy)- -> let (Just treeTc) = UniqMap.lookup treeTcNm tcm- [lrCon,brCon] = tyConDataCons treeTc- in reduce (mkRTree lrCon brCon argTy len (replicate (2^len) (valToTerm (last args))))-------------- Vector----------- "Clash.Sized.Vector.length" -- :: KnownNat n => Vec n a -> Int- | isSubj- , [nTy, _] <- tys- , Right n <-runExcept (tyNatSize tcm nTy)- -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger n)))])-- "Clash.Sized.Vector.maxIndex"- | isSubj- , [nTy, _] <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty- (Just intTc) = UniqMap.lookup intTcNm tcm- [intCon] = tyConDataCons intTc- in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger (n - 1))))])---- Indexing- "Clash.Sized.Vector.index_int" -- :: KnownNat n => Vec n a -> Int- | nTy : aTy : _ <- tys- , _ : xs : i : _ <- args- , DC intDc [Left (Literal (IntLiteral i'))] <- i- -> if i' < 0- then Nothing- else case xs of- DC _ vArgs -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> Nothing- Right n' ->- if i' == 0- then reduceWHNF (Either.lefts vArgs !! 1)- else reduceWHNF $- mkApps (Prim pInfo)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (Data intDc)- [Left (Literal (IntLiteral (i'-1)))])- ]- _ -> Nothing- _ -> Nothing- "Clash.Sized.Vector.head" -- :: Vec (n+1) a -> a- | isSubj- , [DC _ vArgs] <- args- -> reduceWHNF (Either.lefts vArgs !! 1)- "Clash.Sized.Vector.last" -- :: Vec (n+1) a -> a- | isSubj- , [DC _ vArgs] <- args- , (Right _ : Right aTy : Right nTy : _) <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> if n == 0- then reduceWHNF (Either.lefts vArgs !! 1)- else reduceWHNF- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)- ])--- - Sub-vectors- "Clash.Sized.Vector.tail" -- :: Vec (n+1) a -> Vec n a- | isSubj- , [DC _ vArgs] <- args- -> reduceWHNF (Either.lefts vArgs !! 2)- "Clash.Sized.Vector.init" -- :: Vec (n+1) a -> Vec n a- | isSubj- , [DC consCon vArgs] <- args- , (Right _ : Right aTy : Right nTy : _) <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> if n == 0- then reduceWHNF (Either.lefts vArgs !! 2)- else reduce $- mkVecCons consCon aTy n- (Either.lefts vArgs !! 1)- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)])- "Clash.Sized.Vector.select" -- :: (CmpNat (i+s) (s*n) ~ GT) => SNat f -> SNat s -> SNat n -> Vec (f + i) a -> Vec n a- | isSubj- , iTy : sTy : nTy : fTy : aTy : _ <- tys- , eq : f : s : n : xs : _ <- args- , Right n' <- runExcept (tyNatSize tcm nTy)- , Right f' <- runExcept (tyNatSize tcm fTy)- , Right i' <- runExcept (tyNatSize tcm iTy)- , Right s' <- runExcept (tyNatSize tcm sTy)- , DC _ vArgs <- xs- -> case n' of- 0 -> reduce (mkVecNil nilCon aTy)- _ -> case f' of- 0 -> let splitAtCall =- mkApps (splitAtPrim snatTcNm vecTcNm)- [Right sTy- ,Right (LitTy (NumTy (i'-s')))- ,Right aTy- ,Left (valToTerm s)- ,Left (valToTerm xs)- ]- fVecTy = mkTyConApp vecTcNm [sTy,aTy]- iVecTy = mkTyConApp vecTcNm [LitTy (NumTy (i'-s')),aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- fNm = mkUnsafeSystemName "fxs" 0- iNm = mkUnsafeSystemName "ixs" 1- fId = mkLocalId fVecTy fNm- iId = mkLocalId iVecTy iNm- tupPat = DataPat tupDc [] [fId,iId]- iAlt = (tupPat, (Var iId))- in reduce $- mkVecCons consCon aTy n' (Either.lefts vArgs !! 1) $- mkApps (Prim pInfo)- [Right (LitTy (NumTy (i'-s')))- ,Right sTy- ,Right (LitTy (NumTy (n'-1)))- ,Right (LitTy (NumTy 0))- ,Right aTy- ,Left (valToTerm eq)- ,Left (Literal (NaturalLiteral 0))- ,Left (valToTerm s)- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Case splitAtCall iVecTy [iAlt])- ]- _ -> let splitAtCall =- mkApps (splitAtPrim snatTcNm vecTcNm)- [Right fTy- ,Right iTy- ,Right aTy- ,Left (valToTerm f)- ,Left (valToTerm xs)- ]- fVecTy = mkTyConApp vecTcNm [fTy,aTy]- iVecTy = mkTyConApp vecTcNm [iTy,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- fNm = mkUnsafeSystemName "fxs" 0- iNm = mkUnsafeSystemName "ixs" 1- fId = mkLocalId fVecTy fNm- iId = mkLocalId iVecTy iNm- tupPat = DataPat tupDc [] [fId,iId]- iAlt = (tupPat, (Var iId))- in reduceWHNF $- mkApps (Prim pInfo)- [Right iTy- ,Right sTy- ,Right nTy- ,Right (LitTy (NumTy 0))- ,Right aTy- ,Left (valToTerm eq)- ,Left (Literal (NaturalLiteral 0))- ,Left (valToTerm s)- ,Left (valToTerm n)- ,Left (Case splitAtCall iVecTy [iAlt])- ]- where- (tyArgs,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- Just vecTc = UniqMap.lookup vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- TyConApp snatTcNm _ = tyView (Either.rights tyArgs !! 1)- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc--- - Splitting- "Clash.Sized.Vector.splitAt" -- :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)- | isSubj- , (DC snatDc (Right mTy:_)):_ <- args- , Right m <- runExcept (tyNatSize tcm mTy)- -> let _:nTy:aTy:_ = tys- -- Get the tuple data-constructor- ty1 = piResultTys tcm ty tys- (_,tyView -> TyConApp tupTcNm tyArgs@(tyArg:_)) = splitFunForallTy ty1- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- -- Get the vector data-constructors- TyConApp vecTcNm _ = tyView tyArg- Just vecTc = UniqMap.lookup vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- -- Recursive call to @splitAt@- splitAtRec v =- mkApps (Prim pInfo)- [Right (LitTy (NumTy (m-1)))- ,Right nTy- ,Right aTy- ,Left (mkApps (Data snatDc)- [ Right (LitTy (NumTy (m-1)))- , Left (Literal (NaturalLiteral (m-1)))])- ,Left v- ]- -- Projection either the first or second field of the recursive- -- call to @splitAt@- splitAtSelR v = Case (splitAtRec v)- m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]- nVecTy = mkTyConApp vecTcNm [nTy,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- lNm = mkUnsafeSystemName "l" 0- rNm = mkUnsafeSystemName "r" 1- lId = mkLocalId m1VecTy lNm- rId = mkLocalId nVecTy rNm- tupPat = DataPat tupDc [] [lId,rId]- lAlt = (tupPat, (Var lId))- rAlt = (tupPat, (Var rId))-- in case m of- -- (Nil,v)- 0 -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecNil nilCon aTy)- , Left (valToTerm (last args))- ]- -- (x:xs) <- v- m' | DC _ vArgs <- last args- -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))- -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)- (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))- , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])- ]- -- v doesn't reduce to a data-constructor- _ -> Nothing-- "Clash.Sized.Vector.unconcat" -- :: KnownNat n => SNamt m -> Vec (n * m) a -> Vec n (Vec m a)- | isSubj- , kn : snat : v : _ <- args- , nTy : mTy : aTy :_ <- tys- , Lit (NaturalLiteral n) <- kn- -> let ( Either.rights -> argTys, tyView -> TyConApp vecTcNm _) =- splitFunForallTy ty- Just vecTc = UniqMap.lookup vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- TyConApp snatTcNm _ = tyView (argTys !! 1)- n1mTy = mkTyConApp typeNatMul- [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)]- ,mTy]- splitAtCall =- mkApps (splitAtPrim snatTcNm vecTcNm)- [Right mTy- ,Right n1mTy- ,Right aTy- ,Left (valToTerm snat)- ,Left (valToTerm v)- ]- mVecTy = mkTyConApp vecTcNm [mTy,aTy]- n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- asNm = mkUnsafeSystemName "as" 0- bsNm = mkUnsafeSystemName "bs" 1- asId = mkLocalId mVecTy asNm- bsId = mkLocalId n1mVecTy bsNm- tupPat = DataPat tupDc [] [asId,bsId]- asAlt = (tupPat, (Var asId))- bsAlt = (tupPat, (Var bsId))-- in case n of- 0 -> reduce (mkVecNil nilCon mVecTy)- _ -> reduce $- mkVecCons consCon mVecTy n- (Case splitAtCall mVecTy [asAlt])- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n-1)))- ,Right mTy- ,Right aTy- ,Left (Literal (NaturalLiteral (n-1)))- ,Left (valToTerm snat)- ,Left (Case splitAtCall n1mVecTy [bsAlt])])--- Construction--- - initialisation- "Clash.Sized.Vector.replicate" -- :: SNat n -> a -> Vec n a- | isSubj- , let ty' = piResultTys tcm ty tys- , let (_,resTy) = splitFunForallTy ty'- , (TyConApp vecTcNm [lenTy,argTy]) <- tyView resTy- , Right len <- runExcept (tyNatSize tcm lenTy)- -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduce $- mkVec nilCon consCon argTy len- (replicate (fromInteger len) (valToTerm (last args)))--- - Concatenation- "Clash.Sized.Vector.++" -- :: Vec n a -> Vec m a -> Vec (n + m) a- | isSubj- , (DC dc vArgs):_ <- args- , Right nTy : Right aTy : _ <- vArgs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (valToTerm (last args))- n' | (_ : _ : mTy : _) <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- -> -- x : (xs ++ ys)- reduce $- mkVecCons dc aTy (n' + m) (Either.lefts vArgs !! 1)- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Right mTy- ,Left (Either.lefts vArgs !! 2)- ,Left (valToTerm (last args))- ])- _ -> Nothing- "Clash.Sized.Vector.concat" -- :: Vec n (Vec m a) -> Vec (n * m) a- | isSubj- , (nTy : mTy : aTy : _) <- tys- , (xs : _) <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- _ | _ : h' : t : _ <- Either.lefts vArgs- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- -> reduceWHNF $- mkApps (vecAppendPrim vecTcNm)- [Right mTy- ,Right aTy- ,Right $ mkTyConApp typeNatMul- [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)], mTy]- ,Left h'- ,Left $ mkApps (Prim pInfo)- [ Right (LitTy (NumTy (n-1)))- , Right mTy- , Right aTy- , Left t- ]- ]- _ -> Nothing---- Modifying vectors- "Clash.Sized.Vector.replace_int" -- :: KnownNat n => Vec n a -> Int -> a -> Vec n a- | nTy : aTy : _ <- tys- , _ : xs : i : a : _ <- args- , DC intDc [Left (Literal (IntLiteral i'))] <- i- -> if i' < 0- then Nothing- else case xs of- DC vecTcNm vArgs -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> Nothing- Right n' ->- if i' == 0- then reduce (mkVecCons vecTcNm aTy n' (valToTerm a) (Either.lefts vArgs !! 2))- else reduce $- mkVecCons vecTcNm aTy n' (Either.lefts vArgs !! 1)- (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (Literal (NaturalLiteral (n'-1)))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (Data intDc)- [Left (Literal (IntLiteral (i'-1)))])- ,Left (valToTerm a)- ])- _ -> Nothing- _ -> Nothing---- - specialized permutations- "Clash.Sized.Vector.reverse" -- :: Vec n a -> Vec n a- | isSubj- , nTy : aTy : _ <- tys- , [DC vecDc vArgs] <- args- -> case runExcept (tyNatSize tcm nTy) of- Right 0 -> reduce (mkVecNil vecDc aTy)- Right n- | (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , let (Just vecTc) = UniqMap.lookup vecTcNm tcm- , let [nilCon,consCon] = tyConDataCons vecTc- -> reduceWHNF $- mkApps (vecAppendPrim vecTcNm)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Right (LitTy (NumTy 1))- ,Left (mkApps (Prim pInfo)- [Right (LitTy (NumTy (n-1)))- ,Right aTy- ,Left (Either.lefts vArgs !! 2)- ])- ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])- ]- _ -> Nothing- "Clash.Sized.Vector.transpose" -- :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)- | isSubj- , nTy : mTy : aTy : _ <- tys- , kn : xss : _ <- args- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , DC _ vArgs <- xss- , Right n <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- -> case m of- 0 -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduce $- mkVec nilCon consCon (mkTyConApp vecTcNm [mTy,aTy]) n- (replicate (fromInteger n) (mkVec nilCon consCon aTy 0 []))- m' -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm- [_,consCon] = tyConDataCons vecTc- Just (consCoTy : _) = dataConInstArgTys consCon- [mTy,aTy,LitTy (NumTy (m'-1))]- in reduceWHNF $- mkApps (vecZipWithPrim vecTcNm)- [ Right aTy- , Right (mkTyConApp vecTcNm [LitTy (NumTy (m'-1)),aTy])- , Right (mkTyConApp vecTcNm [mTy,aTy])- , Right nTy- , Left (mkApps (Data consCon)- [Right mTy- ,Right aTy- ,Right (LitTy (NumTy (m'-1)))- ,Left (primCo consCoTy)- ])- , Left (Either.lefts vArgs !! 1)- , Left (mkApps (Prim pInfo)- [ Right nTy- , Right (LitTy (NumTy (m'-1)))- , Right aTy- , Left (valToTerm kn)- , Left (Either.lefts vArgs !! 2)- ])- ]-- "Clash.Sized.Vector.rotateLeftS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a- | nTy : aTy : _ : _ <- tys- , kn : xs : d : _ <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- n' | DC snatDc [_,Left d'] <- d- , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf eval tcm isSubj (setTerm d' $ stackClear mach)- -> case (d2 `mod` n) of- 0 -> reduce (valToTerm xs)- d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- (Just vecTc) = UniqMap.lookup vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- in reduceWHNF' mach2 $- mkApps (Prim pInfo)- [Right nTy- ,Right aTy- ,Right (LitTy (NumTy (d3-1)))- ,Left (valToTerm kn)- ,Left (mkApps (vecAppendPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Right (LitTy (NumTy 1))- ,Left (Either.lefts vArgs !! 2)- ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])])- ,Left (mkApps (Data snatDc)- [Right (LitTy (NumTy (d3-1)))- ,Left (Literal (NaturalLiteral (d3-1)))])- ]- _ -> Nothing-- "Clash.Sized.Vector.rotateRightS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a- | isSubj- , nTy : aTy : _ : _ <- tys- , kn : xs : d : _ <- args- , DC dc _ <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc aTy)- n' | DC snatDc [_,Left d'] <- d- , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf eval tcm isSubj (setTerm d' $ stackClear mach)- -> case (d2 `mod` n) of- 0 -> reduce (valToTerm xs)- d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty- in reduceWHNF' mach2 $- mkApps (Prim pInfo)- [Right nTy- ,Right aTy- ,Right (LitTy (NumTy (d3-1)))- ,Left (valToTerm kn)- ,Left (mkVecCons dc aTy n- (mkApps (vecLastPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (valToTerm xs)])- (mkApps (vecInitPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right aTy- ,Left (valToTerm xs)]))- ,Left (mkApps (Data snatDc)- [Right (LitTy (NumTy (d3-1)))- ,Left (Literal (NaturalLiteral (d3-1)))])- ]- _ -> Nothing--- Element-wise operations--- - mapping- "Clash.Sized.Vector.map" -- :: (a -> b) -> Vec n a -> Vec n b- | isSubj- , DC dc vArgs <- args !! 1- , aTy : bTy : nTy : _ <- tys- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc bTy)- n' -> reduce $- mkVecCons dc bTy n'- (mkApps (valToTerm (args !! 0)) [Left (Either.lefts vArgs !! 1)])- (mkApps (Prim pInfo)- [Right aTy- ,Right bTy- ,Right (LitTy (NumTy (n' - 1)))- ,Left (valToTerm (args !! 0))- ,Left (Either.lefts vArgs !! 2)])- "Clash.Sized.Vector.imap" -- :: forall n a b . KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b- | isSubj- , nTy : aTy : bTy : _ <- tys- , (tyArgs,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , let (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 1)- , TyConApp indexTcNm _ <- tyView (Either.rights tyArgs' !! 0)- , Right n <- runExcept (tyNatSize tcm nTy)- , let iLit = mkIndexLit (Either.rights tyArgs' !! 0) nTy n 0- -> reduceWHNF $- mkApps (Prim (PrimInfo "Clash.Sized.Vector.imap_go" (vecImapGoTy vecTcNm indexTcNm) WorkNever SingleResult NoUnfolding))- [Right nTy- ,Right nTy- ,Right aTy- ,Right bTy- ,Left (valToTerm (args !! 1))- ,Left (valToTerm (args !! 2))- ,Left iLit- ]-- "Clash.Sized.Vector.imap_go"- | isSubj- , nTy : mTy : aTy : bTy : _ <- tys- , f : xs : (Suspend nArg) : _ <- args- , DC dc vArgs <- xs- , Right n' <- runExcept (tyNatSize tcm nTy)- , Right m <- runExcept (tyNatSize tcm mTy)- -> case m of- 0 -> reduce (mkVecNil dc bTy)- m'- | eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- , mach1@Machine{mStack=[],mTerm=n} <-- whnf eval tcm True (setTerm nArg (stackClear mach))- -> let (tyArgs,_) = splitFunForallTy ty- TyConApp indexTcNm _ = tyView (Either.rights tyArgs !! 2)- iLit = mkIndexLit (Either.rights tyArgs !! 2) nTy n' 1- in Just $ flip setTerm (mach1 {mStack = mStack mach}) $ mkVecCons dc bTy m'- (mkApps (valToTerm f) [Left n,Left (Either.lefts vArgs !! 1)])- (mkApps (Prim pInfo)- [Right nTy- ,Right (LitTy (NumTy (m'-1)))- ,Right aTy- ,Right bTy- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (Prim (PrimInfo "Clash.Sized.Internal.Index.+#" (indexAddTy indexTcNm) WorkVariable SingleResult NoUnfolding))- [Right nTy- ,Left (Literal (NaturalLiteral n'))- ,Left n- ,Left iLit- ])- ])- | otherwise- -> Nothing-- -- :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a- "Clash.Sized.Vector.iterateI"- | isSubj- , [nTy, aTy] <- tys- , [_n, f, a] <- args- , Right n <- runExcept (tyNatSize tcm nTy)- ->- let- TyConApp vecTcNm _ = tyView (getResultTy tcm ty tys)- Just vecTc = UniqMap.lookup vecTcNm tcm- [nilCon, consCon] = tyConDataCons vecTc- in case n of- 0 -> reduce (mkVecNil nilCon aTy)- _ -> reduce $- mkVecCons consCon aTy n- (valToTerm a)- (mkApps- (Prim pInfo)- [ Right (LitTy (NumTy (n - 1)))- , Right aTy- , Left (valToTerm (Lit (NaturalLiteral (n - 1))))- , Left (valToTerm f)- , Left (mkApps (valToTerm f) [Left (valToTerm a)])- ])---- - Zipping- "Clash.Sized.Vector.zipWith" -- :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c- | isSubj- , aTy : bTy : cTy : nTy : _ <- tys- , f : xs : ys : _ <- args- , DC dc vArgs <- xs- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (mkVecNil dc cTy)- n' -> reduce $ mkVecCons dc cTy n'- (mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)- ,Left (mkApps (vecHeadPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right bTy- ,Left (valToTerm ys)- ])- ])- (mkApps (Prim pInfo)- [Right aTy- ,Right bTy- ,Right cTy- ,Right (LitTy (NumTy (n' - 1)))- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ,Left (mkApps (vecTailPrim vecTcNm)- [Right (LitTy (NumTy (n'-1)))- ,Right bTy- ,Left (valToTerm ys)- ])])---- Folding- "Clash.Sized.Vector.foldr" -- :: (a -> b -> b) -> b -> Vec n a -> b- | isSubj- , aTy : bTy : nTy : _ <- tys- , f : z : xs : _ <- args- , DC _ vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduce (valToTerm z)- _ -> reduceWHNF $- mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)- ,Left (mkApps (Prim pInfo)- [Right aTy- ,Right bTy- ,Right (LitTy (NumTy (n-1)))- ,Left (valToTerm f)- ,Left (valToTerm z)- ,Left (Either.lefts vArgs !! 2)- ])- ]- "Clash.Sized.Vector.fold" -- :: (a -> a -> a) -> Vec (n + 1) a -> a- | isSubj- , nTy : aTy : _ <- tys- , f : vs : _ <- args- , DC _ vArgs <- vs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> reduceWHNF (Either.lefts vArgs !! 1)- _ -> let (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 1)- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- n' = n+1- m = n' `div` 2- n1 = n' - m- mTy = LitTy (NumTy m)- m'ty = LitTy (NumTy (m-1))- n1mTy = LitTy (NumTy n1)- n1m'ty = LitTy (NumTy (n1-1))- splitAtCall =- mkApps (Prim (PrimInfo "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm) WorkNever SingleResult NoUnfolding))- [Right mTy- ,Right n1mTy- ,Right aTy- ,Left (Literal (NaturalLiteral m))- ,Left (valToTerm vs)- ]- mVecTy = mkTyConApp vecTcNm [mTy,aTy]- n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- asNm = mkUnsafeSystemName "as" 0- bsNm = mkUnsafeSystemName "bs" 1- asId = mkLocalId mVecTy asNm- bsId = mkLocalId n1mVecTy bsNm- tupPat = DataPat tupDc [] [asId,bsId]- asAlt = (tupPat, (Var asId))- bsAlt = (tupPat, (Var bsId))- in reduceWHNF $- mkApps (valToTerm f)- [Left (mkApps (Prim pInfo)- [Right m'ty- ,Right aTy- ,Left (valToTerm f)- ,Left (Case splitAtCall mVecTy [asAlt])- ])- ,Left (mkApps (Prim pInfo)- [Right n1m'ty- ,Right aTy- ,Left (valToTerm f)- ,Left (Case splitAtCall n1mVecTy [bsAlt])- ])- ]--- "Clash.Sized.Vector.fold_split" -- :: Natural -> Vec (m + n) a -> (Vec m a, Vec n a)- | isSubj- , mTy : nTy : aTy : _ <- tys- , Right m <- runExcept (tyNatSize tcm mTy)- -> let -- Get the tuple data-constructor- ty1 = piResultTys tcm ty tys- (_,tyView -> TyConApp tupTcNm tyArgs@(tyArg:_)) = splitFunForallTy ty1- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- -- Get the vector data-constructors- TyConApp vecTcNm _ = tyView tyArg- Just vecTc = UniqMap.lookup vecTcNm tcm- [nilCon,consCon] = tyConDataCons vecTc- -- Recursive call to @splitAt@- splitAtRec v =- mkApps (Prim pInfo)- [Right (LitTy (NumTy (m-1)))- ,Right nTy- ,Right aTy- ,Left (Literal (NaturalLiteral (m-1)))- ,Left v- ]- -- Projection either the first or second field of the recursive- -- call to @splitAt@- splitAtSelR v = Case (splitAtRec v)- m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]- nVecTy = mkTyConApp vecTcNm [nTy,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- lNm = mkUnsafeSystemName "l" 0- rNm = mkUnsafeSystemName "r" 1- lId = mkLocalId m1VecTy lNm- rId = mkLocalId nVecTy rNm- tupPat = DataPat tupDc [] [lId,rId]- lAlt = (tupPat, (Var lId))- rAlt = (tupPat, (Var rId))- in case m of- -- (Nil,v)- 0 -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecNil nilCon aTy)- , Left (valToTerm (last args))- ]- -- (x:xs) <- v- m' | DC _ vArgs <- last args- -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))- -> reduce $- mkApps (Data tupDc) $ (map Right tyArgs) ++- [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)- (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))- , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])- ]- -- v doesn't reduce to a data-constructor- _ -> Nothing--- - Specialised folds- "Clash.Sized.Vector.dfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : z : xs : _ <- args- , DC _ vArgs <- xs- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduce (valToTerm z)- _ -> let (tyArgs,_) = splitFunForallTy ty- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 2)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = UniqMap.lookup snatTcNm tcm- [snatDc] = tyConDataCons snatTc- k'ty = LitTy (NumTy (k'-1))- in reduceWHNF $- mkApps (valToTerm f)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (Either.lefts vArgs !! 1)- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm z)- ,Left (Either.lefts vArgs !! 2)- ])- ]- "Clash.Sized.Vector.dtfold"- | isSubj- , pTy : kTy : aTy : _ <- tys- , _ : p : f : g : xs : _ <- args- , DC _ vArgs <- xs- , Right k' <- runExcept (tyNatSize tcm kTy)- -> case k' of- 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts vArgs !! 1)])- _ -> let (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 4)- (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)- TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)- Just snatTc = UniqMap.lookup snatTcNm tcm- [snatDc] = tyConDataCons snatTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- k'ty = LitTy (NumTy (k'-1))- k2ty = LitTy (NumTy (2^(k'-1)))- splitAtCall =- mkApps (splitAtPrim snatTcNm vecTcNm)- [Right k2ty- ,Right k2ty- ,Right aTy- ,Left (mkApps (Data snatDc)- [Right k2ty- ,Left (Literal (NaturalLiteral (2^(k'-1))))])- ,Left (valToTerm xs)- ]- xsSVecTy = mkTyConApp vecTcNm [k2ty,aTy]- -- Guaranteed no capture, so okay to use unsafe name generation- xsLNm = mkUnsafeSystemName "xsL" 0- xsRNm = mkUnsafeSystemName "xsR" 1- xsLId = mkLocalId k2ty xsLNm- xsRId = mkLocalId k2ty xsRNm- tupPat = DataPat tupDc [] [xsLId,xsRId]- asAlt = (tupPat, (Var xsLId))- bsAlt = (tupPat, (Var xsRId))- in reduceWHNF $- mkApps (valToTerm g)- [Right k'ty- ,Left (mkApps (Data snatDc)- [Right k'ty- ,Left (Literal (NaturalLiteral (k'-1)))])- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Case splitAtCall xsSVecTy [asAlt])])- ,Left (mkApps (Prim pInfo)- [Right pTy- ,Right k'ty- ,Right aTy- ,Left (Literal (NaturalLiteral (k'-1)))- ,Left (valToTerm p)- ,Left (valToTerm f)- ,Left (valToTerm g)- ,Left (Case splitAtCall xsSVecTy [bsAlt])])- ]--- Misc- "Clash.Sized.Vector.lazyV"- | isSubj- , nTy : aTy : _ <- tys- , _ : xs : _ <- args- , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm- [nilCon,_] = tyConDataCons vecTc- in reduce (mkVecNil nilCon aTy)- n' -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm- [_,consCon] = tyConDataCons vecTc- in reduce $ mkVecCons consCon aTy n'- (mkApps (vecHeadPrim vecTcNm)- [ Right (LitTy (NumTy (n' - 1)))- , Right aTy- , Left (valToTerm xs)- ])- (mkApps (Prim pInfo)- [ Right (LitTy (NumTy (n' - 1)))- , Right aTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (mkApps (vecTailPrim vecTcNm)- [ Right (LitTy (NumTy (n'-1)))- , Right aTy- , Left (valToTerm xs)- ])- ])--- Traversable- "Clash.Sized.Vector.traverse#"- | isSubj- , aTy : fTy : bTy : nTy : _ <- tys- , apDict : f : xs : _ <- args- , DC dc vArgs <- xs- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 1) ids- in reduceWHNF' (mach { mSupply = ids' }) $- mkApps pureF- [Right (mkTyConApp (vecTcNm) [nTy,bTy])- ,Left (mkVecNil dc bTy)]- _ -> let ((fmapF,apF),ids') = flip runPEM ids $ do- fDict <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 0- fmapF' <- mkSelectorCase $(curLoc) is0 tcm fDict 1 0- apF' <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 2- return (fmapF',apF')- n'ty = LitTy (NumTy (n-1))- Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]- in reduceWHNF' (mach { mSupply = ids' }) $- mkApps apF- [Right (mkTyConApp vecTcNm [n'ty,bTy])- ,Right (mkTyConApp vecTcNm [nTy,bTy])- ,Left (mkApps fmapF- [Right bTy- ,Right (mkFunTy (mkTyConApp vecTcNm [n'ty,bTy])- (mkTyConApp vecTcNm [nTy,bTy]))- ,Left (mkApps (Data dc)- [Right nTy- ,Right bTy- ,Right n'ty- ,Left (primCo consCoTy)])- ,Left (mkApps (valToTerm f)- [Left (Either.lefts vArgs !! 1)])- ])- ,Left (mkApps (Prim pInfo)- [Right aTy- ,Right fTy- ,Right bTy- ,Right n'ty- ,Left (valToTerm apDict)- ,Left (valToTerm f)- ,Left (Either.lefts vArgs !! 2)- ])- ]- where- (tyArgs,_) = splitFunForallTy ty- TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)- (ids, is0) = (mSupply mach, mScopeNames mach)---- BitPack- "Clash.Sized.Vector.concatBitVector#"- | isSubj- , nTy : mTy : _ <- tys- , _ : km : v : _ <- args- , DC _ vArgs <- v- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 -> let resTyInfo = extractTySizeInfo tcm ty tys- in reduce (mkBitVectorLit' resTyInfo 0 0)- n' | Right m <- runExcept (tyNatSize tcm mTy)- , (_,tyView -> TyConApp bvTcNm _) <- splitFunForallTy ty- -> reduceWHNF $- mkApps (bvAppendPrim bvTcNm)- [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])- , Right mTy- , Left (Literal (NaturalLiteral ((n'-1)*m)))- , Left (Either.lefts vArgs !! 1)- , Left (mkApps (Prim pInfo)- [ Right (LitTy (NumTy (n'-1)))- , Right mTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (valToTerm km)- , Left (Either.lefts vArgs !! 2)- ])- ]- _ -> Nothing- "Clash.Sized.Vector.unconcatBitVector#"- | isSubj- , nTy : mTy : _ <- tys- , _ : km : bv : _ <- args- , (_,tyView -> TyConApp vecTcNm [_,bvMTy]) <- splitFunForallTy ty- , TyConApp bvTcNm _ <- tyView bvMTy- , Right n <- runExcept (tyNatSize tcm nTy)- -> case n of- 0 ->- let (Just vecTc) = UniqMap.lookup vecTcNm tcm- [nilCon,_] = tyConDataCons vecTc- in reduce (mkVecNil nilCon (mkTyConApp bvTcNm [mTy]))- n' | Right m <- runExcept (tyNatSize tcm mTy) ->- let Just vecTc = UniqMap.lookup vecTcNm tcm- [_,consCon] = tyConDataCons vecTc- tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)- Just tupTc = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- splitCall =- mkApps (bvSplitPrim bvTcNm)- [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])- , Right mTy- , Left (Literal (NaturalLiteral ((n'-1)*m)))- , Left (valToTerm bv)- ]- mBVTy = mkTyConApp bvTcNm [mTy]- n1BVTy = mkTyConApp bvTcNm- [mkTyConApp typeNatMul- [LitTy (NumTy (n'-1))- ,mTy]]- -- Guaranteed no capture, so okay to use unsafe name generation- xNm = mkUnsafeSystemName "x" 0- bvNm = mkUnsafeSystemName "bv'" 1- xId = mkLocalId mBVTy xNm- bvId = mkLocalId n1BVTy bvNm- tupPat = DataPat tupDc [] [xId,bvId]- xAlt = (tupPat, (Var xId))- bvAlt = (tupPat, (Var bvId))-- in reduce $ mkVecCons consCon (mkTyConApp bvTcNm [mTy]) n'- (Case splitCall mBVTy [xAlt])- (mkApps (Prim pInfo)- [ Right (LitTy (NumTy (n'-1)))- , Right mTy- , Left (Literal (NaturalLiteral (n'-1)))- , Left (valToTerm km)- , Left (Case splitCall n1BVTy [bvAlt])- ])- _ -> Nothing-#if MIN_VERSION_ghc(9,4,0)- "Data.Text.Show.$wunpackCStringAscii#"- | [Lit (StringLiteral addr)] <- args- , Text.Text (Text.ByteArray ba) _off len <- Text.pack addr- -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty- (Just tupTc) = UniqMap.lookup tupTcNm tcm- [tupDc] = tyConDataCons tupTc- ret = mkApps (Data tupDc) (map Right tyArgs ++- [ Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))- , Left (Literal (IntLiteral 0))- , Left (Literal (IntLiteral (toInteger len)))])- in reduce ret- "GHC.Magic.noinlineConstraint"- | [arg] <- args- -> reduce (valToTerm arg)- "GHC.TypeNats.withSomeSNat"- | Lit (NaturalLiteral n) : fun : _ <- args- , _ : funTy : _ <- Either.rights (fst (splitFunForallTy ty))- , (tyView -> TyConApp snatTcNm _) : _ <- Either.rights (fst (splitFunForallTy funTy))- , Just snatTc <- UniqMap.lookup snatTcNm tcm- , [snatDc] <- tyConDataCons snatTc- -> let nTy = LitTy (NumTy n)- snat = mkApps (Data snatDc) [Right nTy, Left (Literal (NaturalLiteral n))]- ret = mkApps (valToTerm fun) [Right nTy, Left snat]- in reduce ret- "GHC.Internal.TypeNats.withSomeSNat"- | Lit (NaturalLiteral n) : fun : _ <- args- , _ : funTy : _ <- Either.rights (fst (splitFunForallTy ty))- , (tyView -> TyConApp snatTcNm _) : _ <- Either.rights (fst (splitFunForallTy funTy))- , Just snatTc <- UniqMap.lookup snatTcNm tcm- , [snatDc] <- tyConDataCons snatTc- -> let nTy = LitTy (NumTy n)- snat = mkApps (Data snatDc) [Right nTy, Left (Literal (NaturalLiteral n))]- ret = mkApps (valToTerm fun) [Right nTy, Left snat]- in reduce ret- "GHC.Magic.nospec"- | [arg] <- args- -> reduce (valToTerm arg)- "GHC.Float.$wproperFractionDouble"- | _ : Lit (DoubleLiteral d) : _ <- args- , [sty@(tyView -> TyConApp signedTcNm [nTy@(LitTy (NumTy kn))])] <- tys- , nameOcc signedTcNm == showt ''Signed- , (_, tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty- , Just tupTc <- UniqMap.lookup tupTcNm tcm- , [tupDc] <- tyConDataCons tupTc- -> let (sn, d1) = reifyNat kn (\p -> first toInteger (op p (wordToDouble d)))- ret = mkApps (Data tupDc) (map Right tyArgs ++- [ Left (mkSignedLit sty nTy kn sn)- , Left (mkDoubleCLit tcm (doubleToWord d1) (last tyArgs))- ])- in reduce ret- where- op :: KnownNat n => Proxy n -> Double -> (Signed n, Double)- op _ = properFraction- "GHC.Internal.Float.$wproperFractionDouble"- | _ : Lit (DoubleLiteral d) : _ <- args- , [sty@(tyView -> TyConApp signedTcNm [nTy@(LitTy (NumTy kn))])] <- tys- , nameOcc signedTcNm == "Clash.Sized.Internal.Signed.Signed"- , (_, tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty- , Just tupTc <- UniqMap.lookup tupTcNm tcm- , [tupDc] <- tyConDataCons tupTc- -> let (sn, d1) = reifyNat kn (\p -> first toInteger (op p (wordToDouble d)))- ret = mkApps (Data tupDc) (map Right tyArgs ++- [ Left (mkSignedLit sty nTy kn sn)- , Left (mkDoubleCLit tcm (doubleToWord d1) (last tyArgs))- ])- in reduce ret- where- op :: KnownNat n => Proxy n -> Double -> (Signed n, Double)- op _ = properFraction-#endif- _ -> Nothing- where- ty = primType pInfo-- checkNaturalRange1 nTy i f =- checkNaturalRange nTy [i]- (\[i'] -> naturalToNaturalLiteral (f i'))-- checkNaturalRange2 nTy i j f =- checkNaturalRange nTy [i, j]- (\[i', j'] -> naturalToNaturalLiteral (f i' j'))-- -- Check given integer's range. If any of them are less than zero, give up- -- and return an undefined type.- checkNaturalRange- :: Type- -- Type of GHC.Natural.Natural ^- -> [Integer]- -> ([Natural] -> Term)- -> Term- checkNaturalRange nTy natsAsInts f =- if any (<0) natsAsInts then- TyApp (Prim NP.undefined) nTy- else- f (map fromInteger natsAsInts)-- reduce :: Term -> Maybe Machine- reduce e = case isX e of- Left msg -> trace (unlines ["Warning: Not evaluating constant expression:", show (primName pInfo), "Because doing so generates an XException:", msg]) Nothing- Right e' -> Just (setTerm e' mach)-- reduceWHNF e =- let eval = Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- mach1@Machine{mStack=[]} = whnf eval tcm isSubj (setTerm e $ stackClear mach)- in Just $ mach1 { mStack = mStack mach }-- reduceWHNF' mach1 e =- let eval = Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind- mach2@Machine{mStack=[]} = whnf eval tcm isSubj (setTerm e mach1)- in Just $ mach2 { mStack = mStack mach }-- makeUndefinedIf :: Exception e => (e -> Bool) -> Term -> Term- makeUndefinedIf wantToHandle tm =- case unsafeDupablePerformIO $ tryJust selectException (evaluate $ force tm) of- Right b -> b- Left e -> trace (msg e) (TyApp (Prim NP.undefined) resTy)- where- resTy = getResultTy tcm ty tys- selectException e | wantToHandle e = Just e- | otherwise = Nothing- msg e = unlines ["Warning: caught exception: \"" ++ show e ++ "\" while trying to evaluate: "- , showPpr (mkApps (Prim pInfo) (map (Left . valToTerm) args))- ]-- catchDivByZero = makeUndefinedIf (==DivideByZero)---- Helper functions for literals--pairOf :: (Value -> Maybe a) -> [Value] -> Maybe (a, a)-pairOf f [x, y] = (,) <$> f x <*> f y-pairOf _ _ = Nothing--listOf :: (Value -> Maybe a) -> [Value] -> [a]-listOf = mapMaybe--wrapUnsigned :: Integer -> Integer -> Integer-wrapUnsigned n i = i `mod` sz- where- sz = 1 `shiftL` fromInteger n--wrapSigned :: Integer -> Integer -> Integer-wrapSigned n i = if n == 0 then 0 else res- where- mask = 1 `shiftL` fromInteger (n - 1)- res = case divMod i mask of- (s,i1) | even s -> i1- | otherwise -> i1 - mask--doubleLiterals' :: [Value] -> [Word64]-doubleLiterals' = listOf doubleLiteral--doubleLiteral :: Value -> Maybe Word64-doubleLiteral v = case v of- Lit (DoubleLiteral i) -> Just i- _ -> Nothing--floatLiterals' :: [Value] -> [Word32]-floatLiterals' = listOf floatLiteral--floatLiteral :: Value -> Maybe Word32-floatLiteral v = case v of- Lit (FloatLiteral i) -> Just i- _ -> Nothing--integerLiterals :: [Value] -> Maybe (Integer, Integer)-integerLiterals = pairOf integerLiteral--integerLiteral :: Value -> Maybe Integer-integerLiteral v =- case v of- Lit (IntegerLiteral i) -> Just i- DC dc [Left (Literal (IntLiteral i))]- | dcTag dc == 1- -> Just i- DC dc [Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))]- | dcTag dc == 2-#if MIN_VERSION_base(4,15,0)- -> Just (IP ba)-#else- -> Just (Jp# (BN# ba))-#endif- | dcTag dc == 3-#if MIN_VERSION_base(4,15,0)- -> Just (IN ba)-#else- -> Just (Jn# (BN# ba))-#endif- _ -> Nothing--naturalLiterals :: [Value] -> Maybe (Integer, Integer)-naturalLiterals = pairOf naturalLiteral--naturalLiteral :: Value -> Maybe Integer-naturalLiteral v =- case v of- Lit (NaturalLiteral i) -> Just i- DC dc [Left (Literal (WordLiteral i))]- | dcTag dc == 1- -> Just i- DC dc [Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))]- | dcTag dc == 2-#if MIN_VERSION_base(4,15,0)- -> Just (IP ba)-#else- -> Just (Jp# (BN# ba))-#endif- _ -> Nothing--integerLiterals' :: [Value] -> [Integer]-integerLiterals' = listOf integerLiteral--naturalLiterals' :: [Value] -> [Integer]-naturalLiterals' = listOf naturalLiteral--intLiterals :: [Value] -> Maybe (Integer,Integer)-intLiterals = pairOf intLiteral--intLiterals' :: [Value] -> [Integer]-intLiterals' = listOf intLiteral--intCLiterals' :: [Value] -> [Integer]-intCLiterals' = listOf intCLiteral--intLiteral :: Value -> Maybe Integer-intLiteral x = case x of- Lit (IntLiteral i) -> Just i- _ -> Nothing--#if MIN_VERSION_base(4,16,0)-int8Literals' :: [Value] -> [Integer]-int8Literals' = listOf int8Literal--int8Literal :: Value -> Maybe Integer-int8Literal x = case x of- Lit (Int8Literal i) -> Just i- _ -> Nothing--int16Literals' :: [Value] -> [Integer]-int16Literals' = listOf int16Literal--int16Literal :: Value -> Maybe Integer-int16Literal x = case x of- Lit (Int16Literal i) -> Just i- _ -> Nothing--int32Literals' :: [Value] -> [Integer]-int32Literals' = listOf int32Literal--int32Literal :: Value -> Maybe Integer-int32Literal x = case x of- Lit (Int32Literal i) -> Just i- _ -> Nothing--#if MIN_VERSION_base(4,17,0)-int64Literals' :: [Value] -> [Integer]-int64Literals' = listOf int64Literal--int64Literal :: Value -> Maybe Integer-int64Literal x = case x of- Lit (Int64Literal i) -> Just i- _ -> Nothing-#endif-#endif--intCLiteral :: Value -> Maybe Integer-intCLiteral v = case v of- (DC _ [Left (Literal (IntLiteral i))]) -> Just i- _ -> Nothing--intCLiterals :: [Value] -> Maybe (Integer, Integer)-intCLiterals = pairOf intCLiteral--wordLiterals :: [Value] -> Maybe (Integer,Integer)-wordLiterals = pairOf wordLiteral--wordLiterals' :: [Value] -> [Integer]-wordLiterals' = listOf wordLiteral--wordLiteral :: Value -> Maybe Integer-wordLiteral x = case x of- Lit (WordLiteral i) -> Just i- _ -> Nothing--#if MIN_VERSION_base(4,16,0)-word8Literals' :: [Value] -> [Integer]-word8Literals' = listOf word8Literal--word8Literal :: Value -> Maybe Integer-word8Literal x = case x of- Lit (Word8Literal i) -> Just i- _ -> Nothing--word16Literals' :: [Value] -> [Integer]-word16Literals' = listOf word16Literal--word16Literal :: Value -> Maybe Integer-word16Literal x = case x of- Lit (Word16Literal i) -> Just i- _ -> Nothing--word32Literals' :: [Value] -> [Integer]-word32Literals' = listOf word32Literal--word32Literal :: Value -> Maybe Integer-word32Literal x = case x of- Lit (Word32Literal i) -> Just i- _ -> Nothing-#endif--word64Literals' :: [Value] -> [Integer]-word64Literals' = listOf word64Literal--#if MIN_VERSION_base(4,17,0)-word64Literal :: Value -> Maybe Integer-word64Literal x = case x of- Lit (Word64Literal i) -> Just i- _ -> Nothing-#else--- Prior to GHC 9.4 Word64# didn't exist, 64 bit primitives took Word# instead-word64Literal :: Value -> Maybe Integer-word64Literal= wordLiteral-#endif--charLiterals :: [Value] -> Maybe (Char,Char)-charLiterals = pairOf charLiteral--charLiterals' :: [Value] -> [Char]-charLiterals' = listOf charLiteral--charLiteral :: Value -> Maybe Char-charLiteral x = case x of- Lit (CharLiteral c) -> Just c- _ -> Nothing--sizedLiterals :: Text -> [Value] -> Maybe (Integer,Integer)-sizedLiterals szCon = pairOf (sizedLiteral szCon)--sizedLiterals' :: Text -> [Value] -> [Integer]-sizedLiterals' szCon = listOf (sizedLiteral szCon)--sizedLiteral :: Text -> Value -> Maybe Integer-sizedLiteral szCon val = case val of- PrimVal p _ [_, Lit (IntegerLiteral i)]- | primName p == szCon -> Just i- _ -> Nothing--bitLiterals- :: [Value]- -> [(Integer,Integer)]-bitLiterals = map normalizeBit . mapMaybe go- where- normalizeBit (msk,v) = (msk .&. 1, v .&. 1)- go val = case val of- PrimVal p _ [Lit (WordLiteral m), Lit (IntegerLiteral i)]- | primName p == "Clash.Sized.Internal.BitVector.fromInteger##"- -> Just (m,i)- _ -> Nothing--indexLiterals, signedLiterals, unsignedLiterals- :: [Value] -> Maybe (Integer,Integer)-indexLiterals = sizedLiterals "Clash.Sized.Internal.Index.fromInteger#"-signedLiterals = sizedLiterals "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLiterals = sizedLiterals "Clash.Sized.Internal.Unsigned.fromInteger#"--indexLiterals', signedLiterals', unsignedLiterals'- :: [Value] -> [Integer]-indexLiterals' = sizedLiterals' "Clash.Sized.Internal.Index.fromInteger#"-signedLiterals' = sizedLiterals' "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLiterals' = sizedLiterals' "Clash.Sized.Internal.Unsigned.fromInteger#"--bitVectorLiterals'- :: [Value] -> [(Integer,Integer)]-bitVectorLiterals' = listOf bitVectorLiteral--bitVectorLiteral :: Value -> Maybe (Integer, Integer)-bitVectorLiteral val = case val of- (PrimVal p _ [_, Lit (NaturalLiteral m), Lit (IntegerLiteral i)])- | primName p == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just (m, i)- _ -> Nothing--toBV :: (Integer,Integer) -> BitVector n-toBV (mask,val) = BV (fromInteger mask) (fromInteger val)--splitBV :: BitVector n -> (Integer,Integer)-splitBV (BV msk val) = (toInteger msk, toInteger val)--toBit :: (Integer,Integer) -> Bit-toBit (mask,val) = Bit (fromInteger mask) (fromInteger val)--valArgs- :: Value- -> Maybe [Term]-valArgs v =- case v of- PrimVal _ _ vs -> Just (fmap valToTerm vs)- DC _ args -> Just (Either.lefts args)- _ -> Nothing---- Tries to match literal arguments to a function like--- (Unsigned.shiftL# :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n)-sizedLitIntLit- :: Text -> TyConMap -> [Type] -> [Value]- -> Maybe (Type,Integer,Integer,Integer)-sizedLitIntLit szCon tcm tys args- | Just (nTy,kn) <- extractKnownNat tcm tys- , [_- ,PrimVal p _ [_,Lit (IntegerLiteral i)]- ,valArgs -> Just [Literal (IntLiteral j)]- ] <- args- , primName p == szCon- = Just (nTy,kn,i,j)- | otherwise- = Nothing--signedLitIntLit, unsignedLitIntLit- :: TyConMap -> [Type] -> [Value]- -> Maybe (Type,Integer,Integer,Integer)-signedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Signed.fromInteger#"-unsignedLitIntLit = sizedLitIntLit "Clash.Sized.Internal.Unsigned.fromInteger#"--bitVectorLitIntLit- :: TyConMap -> [Type] -> [Value]- -> Maybe (Type,Integer,(Integer,Integer),Integer)-bitVectorLitIntLit tcm tys args- | Just (nTy,kn) <- extractKnownNat tcm tys- , [_- ,PrimVal p _ [_,Lit (NaturalLiteral m),Lit (IntegerLiteral i)]- ,valArgs -> Just [Literal (IntLiteral j)]- ] <- args- , primName p == "Clash.Sized.Internal.BitVector.fromInteger#"- = Just (nTy,kn,(m,i),j)- | otherwise- = Nothing--mkIntCLit :: TyConMap -> Integer -> Type -> Term-mkIntCLit tcm lit resTy =- App (Data intDc) (Literal (IntLiteral lit))- where- (_, tyView -> TyConApp intTcNm []) = splitFunForallTy resTy- Just intTc = UniqMap.lookup intTcNm tcm- [intDc] = tyConDataCons intTc--mkFloatCLit :: TyConMap -> Word32 -> Type -> Term-mkFloatCLit tcm lit resTy =- App (Data floatDc) (Literal (FloatLiteral lit))- where- (_, tyView -> TyConApp floatTcNm []) = splitFunForallTy resTy- (Just floatTc) = UniqMap.lookup floatTcNm tcm- [floatDc] = tyConDataCons floatTc--mkDoubleCLit :: TyConMap -> Word64 -> Type -> Term-mkDoubleCLit tcm lit resTy =- App (Data doubleDc) (Literal (DoubleLiteral lit))- where- (_, tyView -> TyConApp doubleTcNm []) = splitFunForallTy resTy- (Just doubleTc) = UniqMap.lookup doubleTcNm tcm- [doubleDc] = tyConDataCons doubleTc--mkSomeNat :: TyConMap -> Integer -> Type -> Term-mkSomeNat tcm lit resTy =- mkApps (Data someNatDc)- [ Right (LitTy (NumTy lit))- , Left (Literal (NaturalLiteral lit))- , Left proxy- ]- where- -- Get the SomeNat data constructor- TyConApp someNatTcNm [] = tyView resTy- (Just someNatTc) = UniqMap.lookup someNatTcNm tcm- [someNatDc] = tyConDataCons someNatTc-- -- Get the Proxy data constructor- (_:_:Right (tyView -> TyConApp proxyTcNm [natTy,_]):_,_) =- splitFunForallTy (dcType someNatDc)- (Just proxyTc) = UniqMap.lookup proxyTcNm tcm- [proxyDc] = tyConDataCons proxyTc-- -- Build the Proxy argument- proxy = mkApps (Data proxyDc)- [ Right natTy- , Right (LitTy (NumTy lit))- ]---- From an argument list to function of type--- forall n. KnownNat n => ...--- extract (nTy,nInt)--- where nTy is the Type of n--- and nInt is its value as an Integer-extractKnownNat :: TyConMap -> [Type] -> Maybe (Type, Integer)-extractKnownNat tcm tys = case tys of- nTy : _ | Right nInt <- runExcept (tyNatSize tcm nTy)- -> Just (nTy, nInt)- _ -> Nothing---- From an argument list to function of type--- forall n m o .. . (KnownNat n, KnownNat m, KnownNat o, ..) => ...--- extract [(nTy,nInt), (mTy,mInt), (oTy,oInt)]--- where nTy is the Type of n--- and nInt is its value as an Integer-extractKnownNats :: TyConMap -> [Type] -> [(Type, Integer)]-extractKnownNats tcm =- mapMaybe (extractKnownNat tcm . pure)---- Construct a constant term of a sized type-mkSizedLit- :: (Type -> Term)- -- ^ Type constructor?- -> Type- -- ^ Result type- -> Type- -- ^ forall n.- -> Integer- -- ^ KnownNat n- -> Integer- -- ^ Value to construct- -> Term-mkSizedLit conPrim ty nTy kn val =- mkApps- (conPrim sTy)- [ Right nTy- , Left (Literal (NaturalLiteral kn))- , Left (Literal (IntegerLiteral val)) ]- where- (_,sTy) = splitFunForallTy ty--mkBitLit- :: Type- -- ^ Result type- -> Integer- -- ^ Mask- -> Integer- -- ^ Value- -> Term-mkBitLit ty msk val =- mkApps (bConPrim sTy) [ Left (Literal (WordLiteral (msk .&. 1)))- , Left (Literal (IntegerLiteral (val .&. 1)))]- where- (_,sTy) = splitFunForallTy ty--mkSignedLit, mkUnsignedLit- :: Type- -- Result type- -> Type- -- forall n.- -> Integer- -- KnownNat n- -> Integer- -- Value- -> Term-mkSignedLit = mkSizedLit signedConPrim-mkUnsignedLit = mkSizedLit unsignedConPrim--mkBitVectorLit- :: Type- -- ^ Result type- -> Type- -- ^ forall n.- -> Integer- -- ^ KnownNat n- -> Integer- -- ^ mask- -> Integer- -- ^ Value to construct- -> Term-mkBitVectorLit ty nTy kn mask val- = mkApps (bvConPrim sTy)- [Right nTy- ,Left (Literal (NaturalLiteral kn))- ,Left (Literal (NaturalLiteral mask))- ,Left (Literal (IntegerLiteral val))]- where- (_,sTy) = splitFunForallTy ty--mkIndexLitE- :: Type- -- ^ Result type- -> Type- -- ^ forall n.- -> Integer- -- ^ KnownNat n- -> Integer- -- ^ Value to construct- -> Either Term Term- -- ^ Either undefined (if given value is out of bounds of given type) or term- -- representing literal-mkIndexLitE rTy nTy kn val- | val >= 0- , val < kn- = Right (mkSizedLit indexConPrim rTy nTy kn val)- | otherwise- = Left (TyApp (Prim NP.undefined) (mkTyConApp indexTcNm [nTy]))- where- TyConApp indexTcNm _ = tyView (snd (splitFunForallTy rTy))--mkIndexLit- :: Type- -- ^ Result type- -> Type- -- ^ forall n.- -> Integer- -- ^ KnownNat n- -> Integer- -- ^ Value to construct- -> Term-mkIndexLit rTy nTy kn val =- either id id (mkIndexLitE rTy nTy kn val)--mkBitVectorLit'- :: (Type, Type, Integer)- -- ^ (result type, forall n., KnownNat n)- -> Integer- -- ^ Mask- -> Integer- -- ^ Value- -> Term-mkBitVectorLit' (ty,nTy,kn) = mkBitVectorLit ty nTy kn--mkIndexLit'- :: (Type, Type, Integer)- -- ^ (result type, forall n., KnownNat n)- -> Integer- -- ^ value- -> Term-mkIndexLit' (rTy,nTy,kn) = mkIndexLit rTy nTy kn--boolToIntLiteral :: Bool -> Term-boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0)--boolToBoolLiteral :: TyConMap -> Type -> Bool -> Term-boolToBoolLiteral tcm ty b =- let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty- (Just boolTc) = UniqMap.lookup boolTcNm tcm- [falseDc,trueDc] = tyConDataCons boolTc- retDc = if b then trueDc else falseDc- in Data retDc--charToCharLiteral :: Char -> Term-charToCharLiteral = Literal . CharLiteral--integerToIntLiteral :: Integer -> Term-integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behavior--integerToWordLiteral :: Integer -> Term-integerToWordLiteral = Literal . WordLiteral . toInteger . (fromInteger :: Integer -> Word) -- for overflow behavior--integerToInt64Literal :: Integer -> Term-integerToInt64Literal = Literal . Int64Literal . toInteger . (fromInteger :: Integer -> Int64) -- for overflow behavior--integerToWord64Literal :: Integer -> Term-integerToWord64Literal = Literal . Word64Literal . toInteger . (fromInteger :: Integer -> Word64) -- for overflow behavior--integerToIntegerLiteral :: Integer -> Term-integerToIntegerLiteral = Literal . IntegerLiteral--naturalToNaturalLiteral :: Natural -> Term-naturalToNaturalLiteral = Literal . NaturalLiteral . toInteger--bConPrim :: Type -> Term-bConPrim (tyView -> TyConApp bTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger##" funTy WorkNever SingleResult NoUnfolding)- where- funTy = foldr1 mkFunTy [wordPrimTy,integerPrimTy,mkTyConApp bTcNm []]-bConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--bvConPrim :: Type -> Term-bvConPrim (tyView -> TyConApp bvTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding)- where- funTy = foldr1 mkFunTy [naturalPrimTy,naturalPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]- nName = mkUnsafeSystemName "n" 0- nVar = VarTy nTV- nTV = mkTyVar typeNatKind nName-bvConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--indexConPrim :: Type -> Term-indexConPrim (tyView -> TyConApp indexTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding)- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]]- nName = mkUnsafeSystemName "n" 0- nVar = VarTy nTV- nTV = mkTyVar typeNatKind nName-indexConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--signedConPrim :: Type -> Term-signedConPrim (tyView -> TyConApp signedTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Signed.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding)- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]]- nName = mkUnsafeSystemName "n" 0- nVar = VarTy nTV- nTV = mkTyVar typeNatKind nName-signedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"--unsignedConPrim :: Type -> Term-unsignedConPrim (tyView -> TyConApp unsignedTcNm _)- = Prim (PrimInfo "Clash.Sized.Internal.Unsigned.fromInteger#" (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding)- where- funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]]- nName = mkUnsafeSystemName "n" 0- nVar = VarTy nTV- nTV = mkTyVar typeNatKind nName-unsignedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"----- | Lift a binary function over 'Unsigned' values to be used as literal Evaluator-------liftUnsigned2 :: KnownNat n- => (Unsigned n -> Unsigned n -> Unsigned n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftUnsigned2 = liftSized2 unsignedLiterals' mkUnsignedLit--liftSigned2 :: KnownNat n- => (Signed n -> Signed n -> Signed n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftSigned2 = liftSized2 signedLiterals' mkSignedLit--liftBitVector2 :: KnownNat n- => (BitVector n -> BitVector n -> BitVector n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftBitVector2 f ty tcm tys args _p- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i,j] <- bitVectorLiterals' args- = let BV mask val = f (toBV i) (toBV j)- in Just $ mkBitVectorLit ty nTy kn (toInteger mask) (toInteger val)- | otherwise = Nothing--liftBitVector2Bool :: KnownNat n- => (BitVector n -> BitVector n -> Bool)- -> Type- -> TyConMap- -> [Value]- -> (Proxy n -> Maybe Term)-liftBitVector2Bool f ty tcm args _p- | [i,j] <- bitVectorLiterals' args- = let val = f (toBV i) (toBV j)- in Just $ boolToBoolLiteral tcm ty val- | otherwise = Nothing--liftInteger2BitVector- :: KnownNat n- => (Integer -> BitVector n)- -> (Type, Type, Integer)- -> [Value]- -> (Proxy n -> Maybe Term)-liftInteger2BitVector f resTyInfo args _p- | [i] <- intCLiterals' args- = let BV msk val = f i- in Just (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))-- | otherwise- = Nothing--liftBitVector2CInt- :: KnownNat n- => TyConMap- -> Type- -> (BitVector n -> Integer)- -> [Value]- -> (Proxy n -> Maybe Term)-liftBitVector2CInt tcm resTy f args _p- | [i] <- bitVectorLiterals' args- = let val = f (toBV i)- in Just $ mkIntCLit tcm val resTy- | otherwise- = Nothing--liftSized2 :: (KnownNat n, Integral (sized n))- => ([Value] -> [Integer])- -- ^ literal argument extraction function- -> (Type -> Type -> Integer -> Integer -> Term)- -- ^ literal contruction function- -> (sized n -> sized n -> sized n)- -> Type- -> TyConMap- -> [Type]- -> [Value]- -> (Proxy n -> Maybe Term)-liftSized2 extractLitArgs mkLit f ty tcm tys args p- | Just (nTy, kn) <- extractKnownNat tcm tys- , [i,j] <- extractLitArgs args- = let val = runSizedF f i j p- in Just $ mkLit ty nTy kn val- | otherwise = Nothing---- | Helper to run a function over sized types on integers------ This only works on function of type (sized n -> sized n -> sized n)--- The resulting function must be executed with reifyNat-runSizedF- :: (KnownNat n, Integral (sized n))- => (sized n -> sized n -> sized n)- -- ^ function to run- -> Integer- -- ^ first argument- -> Integer- -- ^ second argument- -> (Proxy n -> Integer)-runSizedF f i j _ = toInteger $ f (fromInteger i) (fromInteger j)--extractTySizeInfo :: TyConMap -> Type -> [Type] -> (Type, Type, Integer)-extractTySizeInfo tcm ty tys = (resTy,resSizeTy,resSize)- where- ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'- TyConApp _ [resSizeTy] = tyView resTy- Right resSize = runExcept (tyNatSize tcm resSizeTy)--getResultTy- :: TyConMap- -> Type- -> [Type]- -> Type-getResultTy tcm ty tys = resTy- where- ty' = piResultTys tcm ty tys- (_,resTy) = splitFunForallTy ty'--liftDDI :: (Double# -> Double# -> Int#) -> [Value] -> Maybe Term-liftDDI f args = case doubleLiterals' args of- [i,j] -> Just $ runDDI f i j- _ -> Nothing-liftDDD :: (Double# -> Double# -> Double#) -> [Value] -> Maybe Term-liftDDD f args = case doubleLiterals' args of- [i,j] -> Just $ runDDD f i j- _ -> Nothing-liftDD :: (Double# -> Double#) -> [Value] -> Maybe Term-liftDD f args = case doubleLiterals' args of- [i] -> Just $ runDD f i- _ -> Nothing-runDDI :: (Double# -> Double# -> Int#) -> Word64 -> Word64 -> Term-runDDI f i j- = let !(D# a) = wordToDouble i- !(D# b) = wordToDouble j- r = f a b- in Literal . IntLiteral . toInteger $ I# r-runDDD :: (Double# -> Double# -> Double#) -> Word64 -> Word64 -> Term-runDDD f i j- = let !(D# a) = wordToDouble i- !(D# b) = wordToDouble j- r = f a b- in Literal . DoubleLiteral . doubleToWord $ D# r-runDD :: (Double# -> Double#) -> Word64 -> Term-runDD f i- = let !(D# a) = wordToDouble i- r = f a- in Literal . DoubleLiteral . doubleToWord $ D# r--liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term-liftFFI f args = case floatLiterals' args of- [i,j] -> Just $ runFFI f i j- _ -> Nothing-liftFFF :: (Float# -> Float# -> Float#) -> [Value] -> Maybe Term-liftFFF f args = case floatLiterals' args of- [i,j] -> Just $ runFFF f i j- _ -> Nothing-liftFF :: (Float# -> Float#) -> [Value] -> Maybe Term-liftFF f args = case floatLiterals' args of- [i] -> Just $ runFF f i- _ -> Nothing-runFFI :: (Float# -> Float# -> Int#) -> Word32 -> Word32 -> Term-runFFI f i j- = let !(F# a) = wordToFloat i- !(F# b) = wordToFloat j- r = f a b- in Literal . IntLiteral . toInteger $ I# r-runFFF :: (Float# -> Float# -> Float#) -> Word32 -> Word32 -> Term-runFFF f i j- = let !(F# a) = wordToFloat i- !(F# b) = wordToFloat j- r = f a b- in Literal . FloatLiteral . floatToWord $ F# r-runFF :: (Float# -> Float#) -> Word32 -> Term-runFF f i- = let !(F# a) = wordToFloat i- r = f a- in Literal . FloatLiteral . floatToWord $ F# r--#if MIN_VERSION_base(4,16,0)-liftI8 :: (Int8# -> Int8# -> Int8#) -> [Value] -> Maybe Term-liftI8 f args = case int8Literals' args of- [i,j] ->- let !(I8# a) = fromInteger i- !(I8# b) = fromInteger j- in Just (Literal (Int8Literal (toInteger (I8# (f a b)))))- _ -> Nothing--liftI8I :: (Int8# -> Int# -> Int8#) -> [Value] -> Maybe Term-liftI8I f args = case args of- [Lit (Int8Literal i),Lit (IntLiteral j)] ->- let !(I8# a) = fromInteger i- !(I# b) = fromInteger j- in Just (Literal (Int8Literal (toInteger (I8# (f a b)))))- _ -> Nothing--liftI8RI :: (Int8# -> Int8# -> Int#) -> [Value] -> Maybe Term-liftI8RI f args = case int8Literals' args of- [i,j] ->- let !(I8# a) = fromInteger i- !(I8# b) = fromInteger j- in Just (Literal (IntLiteral (toInteger (I# (f a b)))))- _ -> Nothing--liftI16 :: (Int16# -> Int16# -> Int16#) -> [Value] -> Maybe Term-liftI16 f args = case int16Literals' args of- [i,j] ->- let !(I16# a) = fromInteger i- !(I16# b) = fromInteger j- in Just (Literal (Int16Literal (toInteger (I16# (f a b)))))- _ -> Nothing--liftI16I :: (Int16# -> Int# -> Int16#) -> [Value] -> Maybe Term-liftI16I f args = case args of- [Lit (Int16Literal i),Lit (IntLiteral j)] ->- let !(I16# a) = fromInteger i- !(I# b) = fromInteger j- in Just (Literal (Int16Literal (toInteger (I16# (f a b)))))- _ -> Nothing--liftI16RI :: (Int16# -> Int16# -> Int#) -> [Value] -> Maybe Term-liftI16RI f args = case int16Literals' args of- [i,j] ->- let !(I16# a) = fromInteger i- !(I16# b) = fromInteger j- in Just (Literal (IntLiteral (toInteger (I# (f a b)))))- _ -> Nothing--liftI32 :: (Int32# -> Int32# -> Int32#) -> [Value] -> Maybe Term-liftI32 f args = case int32Literals' args of- [i,j] ->- let !(I32# a) = fromInteger i- !(I32# b) = fromInteger j- in Just (Literal (Int32Literal (toInteger (I32# (f a b)))))- _ -> Nothing--liftI32I :: (Int32# -> Int# -> Int32#) -> [Value] -> Maybe Term-liftI32I f args = case args of- [Lit (Int32Literal i),Lit (IntLiteral j)] ->- let !(I32# a) = fromInteger i- !(I# b) = fromInteger j- in Just (Literal (Int32Literal (toInteger (I32# (f a b)))))- _ -> Nothing--liftI32RI :: (Int32# -> Int32# -> Int#) -> [Value] -> Maybe Term-liftI32RI f args = case int32Literals' args of- [i,j] ->- let !(I32# a) = fromInteger i- !(I32# b) = fromInteger j- in Just (Literal (IntLiteral (toInteger (I# (f a b)))))- _ -> Nothing--#if MIN_VERSION_base(4,17,0)-liftI64 :: (Int64# -> Int64# -> Int64#) -> [Value] -> Maybe Term-liftI64 f args = case int64Literals' args of- [i,j] ->- let !(I64# a) = fromInteger i- !(I64# b) = fromInteger j- in Just (Literal (Int64Literal (toInteger (I64# (f a b)))))- _ -> Nothing--liftI64I :: (Int64# -> Int# -> Int64#) -> [Value] -> Maybe Term-liftI64I f args = case args of- [Lit (Int64Literal i),Lit (IntLiteral j)] ->- let !(I64# a) = fromInteger i- !(I# b) = fromInteger j- in Just (Literal (Int64Literal (toInteger (I64# (f a b)))))- _ -> Nothing--liftI64RI :: (Int64# -> Int64# -> Int#) -> [Value] -> Maybe Term-liftI64RI f args = case int64Literals' args of- [i,j] ->- let !(I64# a) = fromInteger i- !(I64# b) = fromInteger j- in Just (Literal (IntLiteral (toInteger (I# (f a b)))))- _ -> Nothing-#endif--liftW8 :: (Word8# -> Word8# -> Word8#) -> [Value] -> Maybe Term-liftW8 f args = case word8Literals' args of- [i,j] ->- let !(W8# a) = fromInteger i- !(W8# b) = fromInteger j- in Just (Literal (Word8Literal (toInteger (W8# (f a b)))))- _ -> Nothing--liftW8I :: (Word8# -> Int# -> Word8#) -> [Value] -> Maybe Term-liftW8I f args = case args of- [Lit (Word8Literal i),Lit (IntLiteral j)] ->- let !(W8# a) = fromInteger i- !(I# b) = fromInteger j- in Just (Literal (Word8Literal (toInteger (W8# (f a b)))))- _ -> Nothing--liftW8RI :: (Word8# -> Word8# -> Int#) -> [Value] -> Maybe Term-liftW8RI f args = case word8Literals' args of- [i,j] ->- let !(W8# a) = fromInteger i- !(W8# b) = fromInteger j- in Just (Literal (IntLiteral (toInteger (I# (f a b)))))- _ -> Nothing--liftW16 :: (Word16# -> Word16# -> Word16#) -> [Value] -> Maybe Term-liftW16 f args = case word16Literals' args of- [i,j] -> let !(W16# a) = fromInteger i- !(W16# b) = fromInteger j- in Just (Literal (Word16Literal (toInteger (W16# (f a b)))))- _ -> Nothing--liftW16I :: (Word16# -> Int# -> Word16#) -> [Value] -> Maybe Term-liftW16I f args = case args of- [Lit (Word16Literal i),Lit (IntLiteral j)] ->- let !(W16# a) = fromInteger i- !(I# b) = fromInteger j- in Just (Literal (Word16Literal (toInteger (W16# (f a b)))))- _ -> Nothing--liftW16RI :: (Word16# -> Word16# -> Int#) -> [Value] -> Maybe Term-liftW16RI f args = case word16Literals' args of- [i,j] ->- let !(W16# a) = fromInteger i- !(W16# b) = fromInteger j- in Just (Literal (IntLiteral (toInteger (I# (f a b)))))- _ -> Nothing--liftW32 :: (Word32# -> Word32# -> Word32#) -> [Value] -> Maybe Term-liftW32 f args = case word32Literals' args of- [i,j] -> let !(W32# a) = fromInteger i- !(W32# b) = fromInteger j- in Just (Literal (Word32Literal (toInteger (W32# (f a b)))))- _ -> Nothing--liftW32I :: (Word32# -> Int# -> Word32#) -> [Value] -> Maybe Term-liftW32I f args = case args of- [Lit (Word32Literal i),Lit (IntLiteral j)] ->- let !(W32# a) = fromInteger i- !(I# b) = fromInteger j- in Just (Literal (Word32Literal (toInteger (W32# (f a b)))))- _ -> Nothing--liftW32RI :: (Word32# -> Word32# -> Int#) -> [Value] -> Maybe Term-liftW32RI f args = case word32Literals' args of- [i,j] ->- let !(W32# a) = fromInteger i- !(W32# b) = fromInteger j- in Just (Literal (IntLiteral (toInteger (I# (f a b)))))- _ -> Nothing--#if MIN_VERSION_base(4,17,0)-liftW64 :: (Word64# -> Word64# -> Word64#) -> [Value] -> Maybe Term-liftW64 f args = case word64Literals' args of- [i,j] -> let !(W64# a) = fromInteger i- !(W64# b) = fromInteger j- in Just (Literal (Word64Literal (toInteger (W64# (f a b)))))- _ -> Nothing--liftW64I :: (Word64# -> Int# -> Word64#) -> [Value] -> Maybe Term-liftW64I f args = case args of- [Lit (Word64Literal i),Lit (IntLiteral j)] ->- let !(W64# a) = fromInteger i- !(I# b) = fromInteger j- in Just (Literal (Word64Literal (toInteger (W64# (f a b)))))- _ -> Nothing--liftW64RI :: (Word64# -> Word64# -> Int#) -> [Value] -> Maybe Term-liftW64RI f args = case word64Literals' args of- [i,j] ->- let !(W64# a) = fromInteger i- !(W64# b) = fromInteger j- in Just (Literal (IntLiteral (toInteger (I# (f a b)))))- _ -> Nothing-#endif-#endif--splitAtPrim- :: TyConName- -- ^ SNat TyCon name- -> TyConName- -- ^ Vec TyCon name- -> Term-splitAtPrim snatTcNm vecTcNm =- Prim (PrimInfo "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm) WorkNever SingleResult NoUnfolding)--splitAtTy- :: TyConName- -- ^ SNat TyCon name- -> TyConName- -- ^ Vec TyCon name- -> Type-splitAtTy snatNm vecNm =- ForAllTy mTV (- ForAllTy nTV (- ForAllTy aTV (- mkFunTy- (mkTyConApp snatNm [VarTy mTV])- (mkFunTy- (mkTyConApp vecNm- [mkTyConApp typeNatAdd- [VarTy mTV- ,VarTy nTV]- ,VarTy aTV])- (mkTyConApp tupNm- [mkTyConApp vecNm- [VarTy mTV- ,VarTy aTV]- ,mkTyConApp vecNm- [VarTy nTV- ,VarTy aTV]])))))- where- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)- tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--foldSplitAtTy- :: TyConName- -- ^ Vec TyCon name- -> Type-foldSplitAtTy vecNm =- ForAllTy mTV (- ForAllTy nTV (- ForAllTy aTV (- mkFunTy- naturalPrimTy- (mkFunTy- (mkTyConApp vecNm- [mkTyConApp typeNatAdd- [VarTy mTV- ,VarTy nTV]- ,VarTy aTV])- (mkTyConApp tupNm- [mkTyConApp vecNm- [VarTy mTV- ,VarTy aTV]- ,mkTyConApp vecNm- [VarTy nTV- ,VarTy aTV]])))))- where- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)- tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--vecAppendPrim- :: TyConName- -- ^ Vec TyCon name- -> Term-vecAppendPrim vecNm =- Prim (PrimInfo "Clash.Sized.Vector.++" (vecAppendTy vecNm) WorkNever SingleResult NoUnfolding)--vecAppendTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecAppendTy vecNm =- ForAllTy nTV (- ForAllTy aTV (- ForAllTy mTV (- mkFunTy- (mkTyConApp vecNm [VarTy nTV- ,VarTy aTV- ])- (mkFunTy- (mkTyConApp vecNm [VarTy mTV- ,VarTy aTV- ])- (mkTyConApp vecNm [mkTyConApp typeNatAdd- [VarTy nTV- ,VarTy mTV]- ,VarTy aTV- ])))))- where- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 2)--vecZipWithPrim- :: TyConName- -- ^ Vec TyCon name- -> Term-vecZipWithPrim vecNm =- Prim (PrimInfo "Clash.Sized.Vector.zipWith" (vecZipWithTy vecNm) WorkNever SingleResult NoUnfolding)--vecZipWithTy- :: TyConName- -- ^ Vec TyCon name- -> Type-vecZipWithTy vecNm =- ForAllTy aTV (- ForAllTy bTV (- ForAllTy cTV (- ForAllTy nTV (- mkFunTy- (mkFunTy aTy (mkFunTy bTy cTy))- (mkFunTy- (mkTyConApp vecNm [nTy,aTy])- (mkFunTy- (mkTyConApp vecNm [nTy,bTy])- (mkTyConApp vecNm [nTy,cTy])))))))- where- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)- bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1)- cTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "c" 2)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 3)- aTy = VarTy aTV- bTy = VarTy bTV- cTy = VarTy cTV- nTy = VarTy nTV--vecImapGoTy- :: TyConName- -- ^ Vec TyCon name- -> TyConName- -- ^ Index TyCon name- -> Type-vecImapGoTy vecTcNm indexTcNm =- ForAllTy nTV (- ForAllTy mTV (- ForAllTy aTV (- ForAllTy bTV (- mkFunTy fTy- (mkFunTy vecATy (mkFunTy indexTy vecBTy))))))- where- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)- aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)- bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 3)- indexTy = mkTyConApp indexTcNm [nTy]- nTy = VarTy nTV- mTy = VarTy mTV- fTy = mkFunTy indexTy (mkFunTy aTy bTy)- aTy = VarTy aTV- bTy = VarTy bTV- vecATy = mkTyConApp vecTcNm [mTy,aTy]- vecBTy = mkTyConApp vecTcNm [mTy,bTy]--indexAddTy- :: TyConName- -- ^ Index TyCon name- -> Type-indexAddTy indexTcNm =- ForAllTy nTV (- mkFunTy naturalPrimTy (mkFunTy indexTy (mkFunTy indexTy indexTy)))- where- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)- indexTy = mkTyConApp indexTcNm [VarTy nTV]--bvAppendPrim- :: TyConName- -- ^ BitVector TyCon Name- -> Term-bvAppendPrim bvTcNm =- Prim (PrimInfo "Clash.Sized.Internal.BitVector.++#" (bvAppendTy bvTcNm) WorkNever SingleResult NoUnfolding)--bvAppendTy- :: TyConName- -- ^ BitVector TyCon Name- -> Type-bvAppendTy bvNm =- ForAllTy mTV (- ForAllTy nTV (- mkFunTy naturalPrimTy (mkFunTy- (mkTyConApp bvNm [VarTy nTV])- (mkFunTy- (mkTyConApp bvNm [VarTy mTV])- (mkTyConApp bvNm [mkTyConApp typeNatAdd- [VarTy nTV- ,VarTy mTV]])))))- where- mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)- nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)--bvSplitPrim- :: TyConName- -- ^ BitVector TyCon Name- -> Term-bvSplitPrim bvTcNm =- Prim (PrimInfo "Clash.Sized.Internal.BitVector.split#" (bvSplitTy bvTcNm) WorkNever SingleResult NoUnfolding)+#include "MachDeps.h"++module Clash.GHC.Evaluator.Primitive+ ( ghcPrimStep+ , ghcPrimUnwind+ , isUndefinedPrimVal+ , isUndefinedXPrimVal+ ) where++import Control.DeepSeq (force)+import Control.Exception (ArithException(..), Exception, tryJust, evaluate)+import Control.Monad.State.Strict (State, MonadState)+import qualified Control.Monad.State.Strict as State+import Control.Monad.Trans.Except (runExcept)+import Data.Binary.IEEE754 (doubleToWord, floatToWord, wordToDouble, wordToFloat)+import Data.Bits+import qualified Data.ByteString.Internal as BS+import Data.Char (chr,ord)+import qualified Data.Either as Either+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.List as List+import qualified Data.Primitive.ByteArray as BA+import Data.Proxy (Proxy)+import Data.Reflection (reifyNat)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Extra (showt)+import GHC.Exts (IsList(..))+import GHC.Float+import GHC.Int+import GHC.Integer+ (decodeDoubleInteger,encodeDoubleInteger,compareInteger,orInteger,andInteger,+ xorInteger,complementInteger,absInteger,signumInteger)+#if MIN_VERSION_base(4,16,0)+import GHC.Num.Integer (Integer (..), integerEncodeFloat#)+#elif MIN_VERSION_base(4,15,0)+import GHC.Num.Integer+ (Integer (..), integerEncodeFloat#, integerToFloat#, integerToDouble#)+#else+import GHC.Integer.GMP.Internals+ (Integer (..), BigNat (..))+#endif+#if MIN_VERSION_base(4,15,0)+import GHC.Num.Natural (naturalSubUnsafe)+#endif+import GHC.Natural+import GHC.ForeignPtr+import GHC.Prim+import GHC.Real (Ratio (..))+import GHC.TypeLits (KnownNat)+import GHC.Types (IO (..))+import GHC.Word+import System.IO.Unsafe (unsafeDupablePerformIO)+#if MIN_VERSION_ghc(9,4,0)+import Data.Bifunctor (first)+import qualified Data.Text.Array as Text+import qualified Data.Text.Internal as Text+#endif++#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Basic (Boxity (..))+import GHC.Types.Name (getSrcSpan, nameOccName, occNameString)+import GHC.Builtin.Names (trueDataConKey, falseDataConKey)+import qualified GHC.Core.TyCon as TyCon+import GHC.Builtin.Types (tupleTyCon)+#else+import BasicTypes (Boxity (..))+import Name (getSrcSpan, nameOccName, occNameString)+import PrelNames (trueDataConKey, falseDataConKey)+import qualified TyCon+import TysWiredIn (tupleTyCon)+#endif++import Clash.Class.BitPack (pack,unpack)+import Clash.Core.DataCon (DataCon (..))+import Clash.Core.Evaluator.Types+import Clash.Core.HasType (piResultTys, applyTypeToArgs)+import Clash.Core.Literal (Literal (..))+import Clash.Core.Name+ (Name (..), NameSort (..), mkUnsafeSystemName)+import Clash.Core.Pretty (showPpr)+import Clash.Core.Term+ (IsMultiPrim (..), Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps,+ PrimUnfolding(..), collectArgs)+import Clash.Core.Type+ (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp,+ splitFunForallTy, tyView)+import Clash.Core.TyCon+ (TyConMap, TyConName, tyConDataCons)+import Clash.Core.TysPrim+import Clash.Core.Util+ (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo, mkSelectorCase,undefinedPrims,+ undefinedXPrims)+import Clash.Core.Var (mkLocalId, mkTyVar)+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Debug+import Clash.GHC.GHC2Core (modNameM)+import Clash.Unique (fromGhcUnique)+import Clash.Util+ (MonadUnique (..), clogBase, flogBase, curLoc, namePat)+import Clash.Util.Supply (Supply,freshId)+import Clash.Normalize.PrimitiveReductions+ (typeNatMul, typeNatSub, typeNatAdd, vecLastPrim, vecInitPrim, vecHeadPrim,+ vecTailPrim, mkVecCons, mkVecNil)++import qualified Clash.Normalize.Primitives as NP+import Clash.Promoted.Nat.Unsafe (unsafeSNat)+import qualified Clash.Sized.Internal.BitVector as BitVector+import qualified Clash.Sized.Internal.Signed as Signed+import qualified Clash.Sized.Internal.Unsigned as Unsigned+import Clash.Sized.Internal.BitVector(BitVector(..), Bit(..))+import Clash.Sized.Internal.Signed (Signed (..))+import Clash.Sized.Internal.Unsigned (Unsigned (..))+import Clash.XException (isX)++import {-# SOURCE #-} Clash.GHC.Evaluator++import qualified Clash.Annotations.BitRepresentation.Deriving+import qualified Clash.Class.BitPack.Internal+import qualified Clash.Class.Exp+import qualified Clash.Promoted.Nat+import qualified Clash.Sized.Internal.BitVector+import qualified Clash.Sized.Internal.Index+import qualified Clash.Sized.Internal.Signed+import qualified Clash.Sized.Internal.Unsigned+import qualified Clash.Sized.RTree+import qualified Clash.Sized.Vector+import qualified GHC.Base+import qualified GHC.Classes+import qualified GHC.CString+import qualified GHC.TypeLits+import qualified GHC.TypeNats+import qualified GHC.Types++#if MIN_VERSION_base(4,15,0)+import qualified GHC.Num+import qualified GHC.Num.Integer+#endif++#if MIN_VERSION_ghc_prim(0,12,0)+import qualified GHC.PrimopWrappers+#endif++#if !MIN_VERSION_base(4,15,0)+import qualified GHC.Integer.Logarithms+#endif++isUndefinedPrimVal :: Value -> Bool+isUndefinedPrimVal (PrimVal (PrimInfo{primName}) _ _) =+ primName `elem` undefinedPrims+isUndefinedPrimVal _ = False++isUndefinedXPrimVal :: Value -> Bool+isUndefinedXPrimVal (PrimVal (PrimInfo{primName}) _ _) =+ primName `elem` undefinedXPrims+isUndefinedXPrimVal _ = False++-- | Evaluation of primitive operations.+ghcPrimUnwind :: PrimUnwind+ghcPrimUnwind tcm p tys vs v [] m+ | primName p `elem` [ showt 'Clash.Sized.Internal.Index.fromInteger#+ , showt 'GHC.CString.unpackCString#+ , showt 'NP.removedArg+ , showt ''MutableByteArray#+ , showt 'NP.undefined+ , showt 'NP.undefinedX+ ]+ -- The above primitives are actually values, and not operations.+ = ghcUnwind (PrimVal p tys (vs ++ [v])) m tcm+ | primName p == showt 'Clash.Sized.Internal.BitVector.fromInteger#+ = case (vs,v) of+ ([naturalLiteral -> Just n,mask], integerLiteral -> Just i) ->+ ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), mask, Lit (IntegerLiteral (wrapUnsigned n i))]) m tcm+ _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))+ | primName p == showt 'Clash.Sized.Internal.BitVector.fromInteger##+ = case (vs,v) of+ ([mask], integerLiteral -> Just i) ->+ ghcUnwind (PrimVal p tys [mask, Lit (IntegerLiteral (wrapUnsigned 1 i))]) m tcm+ _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))+ | primName p == showt 'Clash.Sized.Internal.Signed.fromInteger#+ = case (vs,v) of+ ([naturalLiteral -> Just n],integerLiteral -> Just i) ->+ ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapSigned n i))]) m tcm+ _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))+ | primName p == showt 'Clash.Sized.Internal.Unsigned.fromInteger#+ = case (vs,v) of+ ([naturalLiteral -> Just n],integerLiteral -> Just i) ->+ ghcUnwind (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapUnsigned n i))]) m tcm+ _ -> error ($(curLoc) ++ "Internal error" ++ show (vs,v))+ | isUndefinedPrimVal v+ = let tyArgs = map Right tys+ tmArgs = map (Left . valToTerm) (vs ++ [v])+ in Just $ flip setTerm m $ TyApp (Prim NP.undefined) $+ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+ | isUndefinedXPrimVal v+ = let tyArgs = map Right tys+ tmArgs = map (Left . valToTerm) (vs ++ [v])+ in Just $ flip setTerm m $ TyApp (Prim NP.undefinedX) $+ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+ | otherwise+ = ghcPrimStep tcm (forcePrims m) p tys (vs ++ [v]) m++ghcPrimUnwind tcm p tys vs v [e] m0+ -- Note [Lazy primitives]+ -- ~~~~~~~~~~~~~~~~~~~~~~+ --+ -- Primitives are usually considered undefined when one of their arguments is+ -- (unless they're unused). _Some_ primitives can still yield a result even+ -- though one of their arguments is undefined. It turns out that all primitives+ -- exhibiting this property happen to be "lazy" in their last argument. Thus,+ -- all the cases can be covered by a match on [e] and their names:+ | primName p `elem` [ showt 'Clash.Sized.Vector.lazyV+ , showt 'Clash.Sized.Vector.replicate+ , "Clash.Sized.Vector.replace_int"+ , showt '(GHC.Classes.&&)+ , showt '(GHC.Classes.||)+ , showt 'BitVector.xToBV+ , "Clash.Sized.Vector.imap_go"+ ]+ = if isUndefinedPrimVal v then+ let tyArgs = map Right tys+ tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ [Left e]+ in Just $ flip setTerm m0 $ TyApp (Prim NP.undefined) $+ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+ else+ let (m1,i) = newLetBinding tcm m0 e+ in ghcPrimStep tcm (forcePrims m0) p tys (vs ++ [v,Suspend (Var i)]) m1++ghcPrimUnwind tcm p tys vs (collectValueTicks -> (v, ts)) (e:es) m+ | isUndefinedPrimVal v+ = let tyArgs = map Right tys+ tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ map Left (e:es)+ in Just $ flip setTerm m $ TyApp (Prim NP.undefined) $+ applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+ | otherwise+ = Just . setTerm e $ stackPush (PrimApply p tys (vs ++ [foldr TickValue v ts]) es) m++newtype PrimEvalMonad a = PEM (State Supply a)+ deriving (Functor, Applicative, Monad, MonadState Supply)++instance MonadUnique PrimEvalMonad where+ getUniqueM = PEM $ State.state (\s -> case freshId s of (!i,!s') -> (i,s'))++runPEM :: PrimEvalMonad a -> Supply -> (a, Supply)+runPEM (PEM m) = State.runState m++ghcPrimStep :: PrimStep+ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of+-----------------+-- GHC.Prim.Char#+-----------------+ $(namePat 'GHC.Prim.gtChar#) | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i > j))+ $(namePat 'GHC.Prim.geChar#) | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ $(namePat 'GHC.Prim.eqChar#) | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i == j))+ $(namePat 'GHC.Prim.neChar#) | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ $(namePat 'GHC.Prim.ltChar#) | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i < j))+ $(namePat 'GHC.Prim.leChar#) | Just (i,j) <- charLiterals args+ -> reduce (boolToIntLiteral (i <= j))+ $(namePat 'GHC.Prim.ord#) | [i] <- charLiterals' args+ -> reduce (integerToIntLiteral (toInteger $ ord i))++----------------+-- GHC.Prim.Int#+----------------+ $(namePat '(GHC.Prim.+#)) | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i+j))+ $(namePat '(GHC.Prim.-#)) | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i-j))+ $(namePat '(GHC.Prim.*#)) | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i*j))++ $(namePat 'GHC.Prim.mulIntMayOflo#) | Just (i,j) <- intLiterals args+ -> let !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ c :: Int#+ c = mulIntMayOflo# a b+ in reduce (integerToIntLiteral (toInteger $ I# c))++ $(namePat 'GHC.Prim.quotInt#) | Just (i,j) <- intLiterals args+ -> reduce $ catchDivByZero (integerToIntLiteral (i `quot` j))+ $(namePat 'GHC.Prim.remInt#) | Just (i,j) <- intLiterals args+ -> reduce $ catchDivByZero (integerToIntLiteral (i `rem` j))+ $(namePat 'GHC.Prim.quotRemInt#) | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [Left $ catchDivByZero (integerToIntLiteral q)+ ,Left $ catchDivByZero (integerToIntLiteral r)])+ in reduce ret++ $(namePat 'GHC.Prim.andI#) | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i .&. j))+ $(namePat 'GHC.Prim.orI#) | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i .|. j))+ $(namePat 'GHC.Prim.xorI#) | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i `xor` j))+ $(namePat 'GHC.Prim.notI#) | [i] <- intLiterals' args+ -> reduce (integerToIntLiteral (complement i))++ $(namePat 'GHC.Prim.negateInt#)+ | [Lit (IntLiteral i)] <- args+ -> reduce (integerToIntLiteral (negate i))++ $(namePat 'GHC.Prim.addIntC#) | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ !(# d, c #) = addIntC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])+ $(namePat 'GHC.Prim.subIntC#) | Just (i,j) <- intLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ !(# d, c #) = subIntC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])++ $(namePat '(GHC.Prim.>#)) | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i > j))+ $(namePat '(GHC.Prim.>=#)) | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ $(namePat '(GHC.Prim.==#)) | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i == j))+ $(namePat '(GHC.Prim./=#)) | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ $(namePat '(GHC.Prim.<#))| Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i < j))+ $(namePat '(GHC.Prim.<=#)) | Just (i,j) <- intLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ $(namePat 'GHC.Prim.chr#) | [i] <- intLiterals' args+ -> reduce (charToCharLiteral (chr $ fromInteger i))++ $(namePat 'GHC.Prim.int2Word#)+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . WordLiteral . toInteger $ (fromInteger :: Integer -> Word) i -- for overflow behavior++ $(namePat 'GHC.Prim.int2Float#)+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . FloatLiteral . floatToWord $ fromInteger i+ $(namePat 'GHC.Prim.int2Double#)+ | [Lit (IntLiteral i)] <- args+ -> reduce . Literal . DoubleLiteral . doubleToWord $ fromInteger i++ $(namePat 'GHC.Prim.word2Float#)+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . FloatLiteral . floatToWord $ fromInteger i+ $(namePat 'GHC.Prim.word2Double#)+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . DoubleLiteral . doubleToWord $ fromInteger i++ $(namePat 'GHC.Prim.uncheckedIShiftL#)+ | [ Lit (IntLiteral i)+ , Lit (IntLiteral s)+ ] <- args+ -> reduce (integerToIntLiteral (i `shiftL` fromInteger s))+ $(namePat 'GHC.Prim.uncheckedIShiftRA#)+ | [ Lit (IntLiteral i)+ , Lit (IntLiteral s)+ ] <- args+ -> reduce (integerToIntLiteral (i `shiftR` fromInteger s))+ $(namePat 'GHC.Prim.uncheckedIShiftRL#) | Just (i,j) <- intLiterals args+ -> let !(I# a) = fromInteger i+ !(I# b) = fromInteger j+ c :: Int#+ c = uncheckedIShiftRL# a b+ in reduce (integerToIntLiteral (toInteger $ I# c))++-----------------+-- GHC.Prim.Word#+-----------------+ $(namePat 'GHC.Prim.plusWord#) | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i+j))++ $(namePat 'GHC.Prim.subWordC#) | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# d, c #) = subWordC# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# d)+ , Left (Literal . IntLiteral . toInteger $ I# c)])++ $(namePat 'GHC.Prim.plusWord2#) | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# h', l #) = plusWord2# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# h')+ , Left (Literal . WordLiteral . toInteger $ W# l)])++ $(namePat 'GHC.Prim.minusWord#) | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i-j))+ $(namePat 'GHC.Prim.timesWord#) | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i*j))++ $(namePat 'GHC.Prim.timesWord2#) | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(# h', l #) = timesWord2# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . WordLiteral . toInteger $ W# h')+ , Left (Literal . WordLiteral . toInteger $ W# l)])++ $(namePat 'GHC.Prim.quotWord#) | Just (i,j) <- wordLiterals args+ -> reduce $ catchDivByZero (integerToWordLiteral (i `quot` j))+ $(namePat 'GHC.Prim.remWord#) | Just (i,j) <- wordLiterals args+ -> reduce $ catchDivByZero (integerToWordLiteral (i `rem` j))+ $(namePat 'GHC.Prim.quotRemWord#) | Just (i,j) <- wordLiterals args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [Left $ catchDivByZero (integerToWordLiteral q)+ ,Left $ catchDivByZero (integerToWordLiteral r)])+ in reduce ret+ $(namePat 'GHC.Prim.quotRemWord2#) | [i,j,k'] <- wordLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(W# a) = fromInteger i+ !(W# b) = fromInteger j+ !(W# c) = fromInteger k'+ !(# x, y #) = quotRemWord2# a b c+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# x)+ , Left $ catchDivByZero (Literal . WordLiteral . toInteger $ W# y)])++ $(namePat 'GHC.Prim.and#) | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i .&. j))+ $(namePat 'GHC.Prim.or#) | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i .|. j))+ $(namePat 'GHC.Prim.xor#) | Just (i,j) <- wordLiterals args+ -> reduce (integerToWordLiteral (i `xor` j))+ $(namePat 'GHC.Prim.not#) | [i] <- wordLiterals' args+ -> reduce (integerToWordLiteral (complement i))++ $(namePat 'GHC.Prim.uncheckedShiftL#)+ | [ Lit (WordLiteral w)+ , Lit (IntLiteral i)+ ] <- args+ -> reduce (Literal (WordLiteral (w `shiftL` fromInteger i)))+ $(namePat 'GHC.Prim.uncheckedShiftRL#)+ | [ Lit (WordLiteral w)+ , Lit (IntLiteral i)+ ] <- args+ -> reduce (Literal (WordLiteral (w `shiftR` fromInteger i)))++ $(namePat 'GHC.Prim.word2Int#)+ | [Lit (WordLiteral i)] <- args+ -> reduce . Literal . IntLiteral . toInteger $ (fromInteger :: Integer -> Int) i -- for overflow behavior++ $(namePat 'GHC.Prim.gtWord#) | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i > j))+ $(namePat 'GHC.Prim.geWord#) | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i >= j))+ $(namePat 'GHC.Prim.eqWord#) | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i == j))+ $(namePat 'GHC.Prim.neWord#) | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i /= j))+ $(namePat 'GHC.Prim.ltWord#) | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i < j))+ $(namePat 'GHC.Prim.leWord#) | Just (i,j) <- wordLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ $(namePat 'GHC.Prim.popCnt8#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word8) $ i+ $(namePat 'GHC.Prim.popCnt16#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word16) $ i+ $(namePat 'GHC.Prim.popCnt32#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word32) $ i+ $(namePat 'GHC.Prim.popCnt64#) | [i] <- word64Literals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word64) $ i+ $(namePat 'GHC.Prim.popCnt#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word) $ i++ $(namePat 'GHC.Prim.clz8#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word8) $ i+ $(namePat 'GHC.Prim.clz16#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word16) $ i+ $(namePat 'GHC.Prim.clz32#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word32) $ i+ $(namePat 'GHC.Prim.clz64#) | [i] <- word64Literals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word64) $ i+ $(namePat 'GHC.Prim.clz#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word) $ i++ $(namePat 'GHC.Prim.ctz8#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 8 - 1)+ $(namePat 'GHC.Prim.ctz16#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 16 - 1)+ $(namePat 'GHC.Prim.ctz32#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 32 - 1)+ $(namePat 'GHC.Prim.ctz64#) | [i] <- word64Literals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word64) $ i .&. (bit 64 - 1)+ $(namePat 'GHC.Prim.ctz#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i++ $(namePat 'GHC.Prim.byteSwap16#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap16 . (fromInteger :: Integer -> Word16) $ i+ $(namePat 'GHC.Prim.byteSwap32#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap32 . (fromInteger :: Integer -> Word32) $ i+ $(namePat 'GHC.Prim.byteSwap64#) | [i] <- word64Literals' args+ -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i+ $(namePat 'GHC.Prim.byteSwap#) | [i] <- wordLiterals' args -- assume 64bits+ -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i++#if MIN_VERSION_base(4,14,0)+ $(namePat 'GHC.Prim.bitReverse#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i -- assume 64bits+ $(namePat 'GHC.Prim.bitReverse8#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse8 . fromInteger $ i+ $(namePat 'GHC.Prim.bitReverse16#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse16 . fromInteger $ i+ $(namePat 'GHC.Prim.bitReverse32#) | [i] <- wordLiterals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse32 . fromInteger $ i+ $(namePat 'GHC.Prim.bitReverse64#) | [i] <- word64Literals' args+ -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i+#endif+------------+-- Narrowing+------------+ $(namePat 'GHC.Prim.narrow8Int#) | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow8Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ $(namePat 'GHC.Prim.narrow16Int#) | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow16Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ $(namePat 'GHC.Prim.narrow32Int#) | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow32Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# b+ $(namePat 'GHC.Prim.narrow8Word#) | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow8Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b+ $(namePat 'GHC.Prim.narrow16Word#) | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow16Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b+ $(namePat 'GHC.Prim.narrow32Word#) | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow32Word# a+ in reduce . Literal . WordLiteral . toInteger $ W# b++#if MIN_VERSION_base(4,16,0)+--------+-- Int8#+--------+ $(namePat 'GHC.Prim.intToInt8#) | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow8Int# a+ 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+ -> let !(I8# a) = fromInteger i+ in reduce (Literal (Int8Literal (toInteger (I8# (negateInt8# a)))))+ $(namePat 'GHC.Prim.plusInt8#) | Just r <- liftI8 plusInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.subInt8#) | Just r <- liftI8 subInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.timesInt8#) | Just r <- liftI8 timesInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.quotInt8#) | Just r <- liftI8 quotInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.remInt8#) | Just r <- liftI8 remInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.quotRemInt8#)+ | [i, j] <- int8Literals' args+ , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty+ , (Just tupTc) <- UniqMap.lookup tupTcNm tcm+ , [tupDc] <- tyConDataCons tupTc+ -> let !(I8# a) = fromInteger i+ !(I8# b) = fromInteger j+ !(# q, r #) = quotRemInt8# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal (Int8Literal (toInteger (I8# q))))+ , Left (Literal (Int8Literal (toInteger (I8# r))))])+ $(namePat 'GHC.Prim.uncheckedShiftLInt8#) | Just r <- liftI8I uncheckedShiftLInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRAInt8#) | Just r <- liftI8I uncheckedShiftRAInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRLInt8#) | Just r <- liftI8I uncheckedShiftRLInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.int8ToWord8#) | [i] <- int8Literals' args+ -> let !(I8# a) = fromInteger i+ in reduce (Literal (Word8Literal (toInteger (W8# (int8ToWord8# a)))))+ $(namePat 'GHC.Prim.eqInt8#) | Just r <- liftI8RI eqInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.geInt8#) | Just r <- liftI8RI geInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.gtInt8#) | Just r <- liftI8RI gtInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.leInt8#) | Just r <- liftI8RI leInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.ltInt8#) | Just r <- liftI8RI ltInt8# args+ -> reduce r+ $(namePat 'GHC.Prim.neInt8#) | Just r <- liftI8RI neInt8# args+ -> reduce r++---------+-- Int16#+---------+ $(namePat 'GHC.Prim.intToInt16#) | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow16Int# a+ 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+ -> let !(I16# a) = fromInteger i+ in reduce (Literal (Int16Literal (toInteger (I16# (negateInt16# a)))))+ $(namePat 'GHC.Prim.plusInt16#) | Just r <- liftI16 plusInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.subInt16#) | Just r <- liftI16 subInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.timesInt16#) | Just r <- liftI16 timesInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.quotInt16#) | Just r <- liftI16 quotInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.remInt16#) | Just r <- liftI16 remInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.quotRemInt16#)+ | [i, j] <- int16Literals' args+ , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty+ , (Just tupTc) <- UniqMap.lookup tupTcNm tcm+ , [tupDc] <- tyConDataCons tupTc+ -> let !(I16# a) = fromInteger i+ !(I16# b) = fromInteger j+ !(# q, r #) = quotRemInt16# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal (Int16Literal (toInteger (I16# q))))+ , Left (Literal (Int16Literal (toInteger (I16# r))))])+ $(namePat 'GHC.Prim.uncheckedShiftLInt16#) | Just r <- liftI16I uncheckedShiftLInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRAInt16#) | Just r <- liftI16I uncheckedShiftRAInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRLInt16#) | Just r <- liftI16I uncheckedShiftRLInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.int16ToWord16#) | [i] <- int16Literals' args+ -> let !(I16# a) = fromInteger i+ in reduce (Literal (Word16Literal (toInteger (W16# (int16ToWord16# a)))))+ $(namePat 'GHC.Prim.eqInt16#) | Just r <- liftI16RI eqInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.geInt16#) | Just r <- liftI16RI geInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.gtInt16#) | Just r <- liftI16RI gtInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.leInt16#) | Just r <- liftI16RI leInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.ltInt16#) | Just r <- liftI16RI ltInt16# args+ -> reduce r+ $(namePat 'GHC.Prim.neInt16#) | Just r <- liftI16RI neInt16# args+ -> reduce r++---------+-- Int32#+---------+ $(namePat 'GHC.Prim.intToInt32#) | [i] <- intLiterals' args+ -> let !(I# a) = fromInteger i+ b = narrow32Int# a+ 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+ -> let !(I32# a) = fromInteger i+ in reduce (Literal (Int32Literal (toInteger (I32# (negateInt32# a)))))+ $(namePat 'GHC.Prim.plusInt32#) | Just r <- liftI32 plusInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.subInt32#) | Just r <- liftI32 subInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.timesInt32#) | Just r <- liftI32 timesInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.quotInt32#) | Just r <- liftI32 quotInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.remInt32#) | Just r <- liftI32 remInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.quotRemInt32#)+ | [i, j] <- int32Literals' args+ , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty+ , (Just tupTc) <- UniqMap.lookup tupTcNm tcm+ , [tupDc] <- tyConDataCons tupTc+ -> let !(I32# a) = fromInteger i+ !(I32# b) = fromInteger j+ !(# q, r #) = quotRemInt32# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal (Int32Literal (toInteger (I32# q))))+ , Left (Literal (Int32Literal (toInteger (I32# r))))])+ $(namePat 'GHC.Prim.uncheckedShiftLInt32#) | Just r <- liftI32I uncheckedShiftLInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRAInt32#) | Just r <- liftI32I uncheckedShiftRAInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRLInt32#) | Just r <- liftI32I uncheckedShiftRLInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.int32ToWord32#) | [i] <- int32Literals' args+ -> let !(I32# a) = fromInteger i+ in reduce (Literal (Word32Literal (toInteger (W32# (int32ToWord32# a)))))+ $(namePat 'GHC.Prim.eqInt32#) | Just r <- liftI32RI eqInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.geInt32#) | Just r <- liftI32RI geInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.gtInt32#) | Just r <- liftI32RI gtInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.leInt32#) | Just r <- liftI32RI leInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.ltInt32#) | Just r <- liftI32RI ltInt32# args+ -> reduce r+ $(namePat 'GHC.Prim.neInt32#) | Just r <- liftI32RI neInt32# args+ -> reduce r++---------+-- Int64#+---------+#if MIN_VERSION_base(4,17,0)+ $(namePat 'GHC.Prim.intToInt64#) | [i] <- intLiterals' args+ -> 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+ -> let !(I64# a) = fromInteger i+ in reduce (Literal (Int64Literal (toInteger (I64# (negateInt64# a)))))+ $(namePat 'GHC.Prim.plusInt64#) | Just r <- liftI64 plusInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.subInt64#) | Just r <- liftI64 subInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.timesInt64#) | Just r <- liftI64 timesInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.quotInt64#) | Just r <- liftI64 quotInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.remInt64#) | Just r <- liftI64 remInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedIShiftL64#) | Just r <- liftI64I uncheckedIShiftL64# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedIShiftRA64#) | Just r <- liftI64I uncheckedIShiftRA64# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedIShiftRL64#) | Just r <- liftI64I uncheckedIShiftRL64# args+ -> reduce r+ $(namePat 'GHC.Prim.int64ToWord64#) | [i] <- int64Literals' args+ -> let !(I64# a) = fromInteger i+ in reduce (Literal (Word64Literal (toInteger (W64# (int64ToWord64# a)))))+ $(namePat 'GHC.Prim.eqInt64#) | Just r <- liftI64RI eqInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.geInt64#) | Just r <- liftI64RI geInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.gtInt64#) | Just r <- liftI64RI gtInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.leInt64#) | Just r <- liftI64RI leInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.ltInt64#) | Just r <- liftI64RI ltInt64# args+ -> reduce r+ $(namePat 'GHC.Prim.neInt64#) | Just r <- liftI64RI neInt64# args+ -> reduce r+#endif++---------+-- Word8#+---------+ $(namePat 'GHC.Prim.wordToWord8#) | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow8Word# a+ in reduce . Literal . Word8Literal . toInteger $ W# b+ $(namePat 'GHC.Prim.word8ToWord#) | [i] <- word8Literals' args+ -> reduce . Literal $ WordLiteral i+ $(namePat 'GHC.Prim.plusWord8#) | Just r <- liftW8 plusWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.subWord8#) | Just r <- liftW8 subWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.timesWord8#) | Just r <- liftW8 timesWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.quotWord8#) | Just r <- liftW8 quotWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.remWord8#) | Just r <- liftW8 remWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.quotRemWord8#)+ | [i, j] <- word8Literals' args+ , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty+ , (Just tupTc) <- UniqMap.lookup tupTcNm tcm+ , [tupDc] <- tyConDataCons tupTc+ -> let !(W8# a) = fromInteger i+ !(W8# b) = fromInteger j+ !(# q, r #) = quotRemWord8# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal (Word8Literal (toInteger (W8# q))))+ , Left (Literal (Word8Literal (toInteger (W8# r))))])+ $(namePat 'GHC.Prim.andWord8#) | Just r <- liftW8 andWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.orWord8#) | Just r <- liftW8 orWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.xorWord8#) | Just r <- liftW8 xorWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.notWord8#) | [i] <- word8Literals' args+ -> let !(W8# a) = fromInteger i+ in reduce (Literal (Word8Literal (toInteger (W8# (notWord8# a)))))+ $(namePat 'GHC.Prim.uncheckedShiftLWord8#) | Just r <- liftW8I uncheckedShiftLWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRLWord8#) | Just r <- liftW8I uncheckedShiftRLWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.word8ToInt8#) | [i] <- word8Literals' args+ -> let !(W8# a) = fromInteger i+ in reduce (Literal (Int8Literal (toInteger (I8# (word8ToInt8# a)))))+ $(namePat 'GHC.Prim.eqWord8#) | Just r <- liftW8RI eqWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.geWord8#) | Just r <- liftW8RI geWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.gtWord8#) | Just r <- liftW8RI gtWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.leWord8#) | Just r <- liftW8RI leWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.ltWord8#) | Just r <- liftW8RI ltWord8# args+ -> reduce r+ $(namePat 'GHC.Prim.neWord8#) | Just r <- liftW8RI neWord8# args+ -> reduce r++----------+-- Word16#+----------+ $(namePat 'GHC.Prim.wordToWord16#) | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow16Word# a+ in reduce . Literal . Word16Literal . toInteger $ W# b+ $(namePat 'GHC.Prim.word16ToWord#) | [i] <- word16Literals' args+ -> reduce . Literal $ WordLiteral i+ $(namePat 'GHC.Prim.plusWord16#) | Just r <- liftW16 plusWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.subWord16#) | Just r <- liftW16 subWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.timesWord16#) | Just r <- liftW16 timesWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.quotWord16#) | Just r <- liftW16 quotWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.remWord16#) | Just r <- liftW16 remWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.quotRemWord16#)+ | [i, j] <- word16Literals' args+ , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty+ , (Just tupTc) <- UniqMap.lookup tupTcNm tcm+ , [tupDc] <- tyConDataCons tupTc+ -> let !(W16# a) = fromInteger i+ !(W16# b) = fromInteger j+ !(# q, r #) = quotRemWord16# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal (Word16Literal (toInteger (W16# q))))+ , Left (Literal (Word16Literal (toInteger (W16# r))))])+ $(namePat 'GHC.Prim.andWord16#) | Just r <- liftW16 andWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.orWord16#) | Just r <- liftW16 orWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.xorWord16#) | Just r <- liftW16 xorWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.notWord16#) | [i] <- word16Literals' args+ -> let !(W16# a) = fromInteger i+ in reduce (Literal (Word16Literal (toInteger (W16# (notWord16# a)))))+ $(namePat 'GHC.Prim.uncheckedShiftLWord16#) | Just r <- liftW16I uncheckedShiftLWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRLWord16#) | Just r <- liftW16I uncheckedShiftRLWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.word16ToInt16#) | [i] <- word16Literals' args+ -> let !(W16# a) = fromInteger i+ in reduce (Literal (Int16Literal (toInteger (I16# (word16ToInt16# a)))))+ $(namePat 'GHC.Prim.eqWord16#) | Just r <- liftW16RI eqWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.geWord16#) | Just r <- liftW16RI geWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.gtWord16#) | Just r <- liftW16RI gtWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.leWord16#) | Just r <- liftW16RI leWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.ltWord16#) | Just r <- liftW16RI ltWord16# args+ -> reduce r+ $(namePat 'GHC.Prim.neWord16#) | Just r <- liftW16RI neWord16# args+ -> reduce r++----------+-- Word32#+----------+ $(namePat 'GHC.Prim.wordToWord32#) | [i] <- wordLiterals' args+ -> let !(W# a) = fromInteger i+ b = narrow32Word# a+ in reduce . Literal . Word32Literal . toInteger $ W# b+ $(namePat 'GHC.Prim.word32ToWord#) | [i] <- word32Literals' args+ -> reduce . Literal $ WordLiteral i+ $(namePat 'GHC.Prim.plusWord32#) | Just r <- liftW32 plusWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.subWord32#) | Just r <- liftW32 subWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.timesWord32#) | Just r <- liftW32 timesWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.quotWord32#) | Just r <- liftW32 quotWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.remWord32#) | Just r <- liftW32 remWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.quotRemWord32#)+ | [i, j] <- word32Literals' args+ , (_,tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty+ , (Just tupTc) <- UniqMap.lookup tupTcNm tcm+ , [tupDc] <- tyConDataCons tupTc+ -> let !(W32# a) = fromInteger i+ !(W32# b) = fromInteger j+ !(# q, r #) = quotRemWord32# a b+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal (Word32Literal (toInteger (W32# q))))+ , Left (Literal (Word32Literal (toInteger (W32# r))))])+ $(namePat 'GHC.Prim.andWord32#) | Just r <- liftW32 andWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.orWord32#) | Just r <- liftW32 orWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.xorWord32#) | Just r <- liftW32 xorWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.notWord32#) | [i] <- word32Literals' args+ -> let !(W32# a) = fromInteger i+ in reduce (Literal (Word32Literal (toInteger (W32# (notWord32# a)))))+ $(namePat 'GHC.Prim.uncheckedShiftLWord32#) | Just r <- liftW32I uncheckedShiftLWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRLWord32#) | Just r <- liftW32I uncheckedShiftRLWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.word32ToInt32#) | [i] <- word32Literals' args+ -> let !(W32# a) = fromInteger i+ in reduce (Literal (Int32Literal (toInteger (I32# (word32ToInt32# a)))))+ $(namePat 'GHC.Prim.eqWord32#) | Just r <- liftW32RI eqWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.geWord32#) | Just r <- liftW32RI geWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.gtWord32#) | Just r <- liftW32RI gtWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.leWord32#) | Just r <- liftW32RI leWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.ltWord32#) | Just r <- liftW32RI ltWord32# args+ -> reduce r+ $(namePat 'GHC.Prim.neWord32#) | Just r <- liftW32RI neWord32# args+ -> reduce r++#if MIN_VERSION_base(4,17,0)+----------+-- Word64#+----------+ $(namePat 'GHC.Prim.wordToWord64#) | [i] <- wordLiterals' args+ -> reduce (Literal (Word64Literal i))+ $(namePat 'GHC.Prim.word64ToWord#) | [i] <- word64Literals' args+ -> reduce . Literal $ WordLiteral i+ $(namePat 'GHC.Prim.plusWord64#) | Just r <- liftW64 plusWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.subWord64#) | Just r <- liftW64 subWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.timesWord64#) | Just r <- liftW64 timesWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.quotWord64#) | Just r <- liftW64 quotWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.remWord64#) | Just r <- liftW64 remWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.and64#) | Just r <- liftW64 and64# args+ -> reduce r+ $(namePat 'GHC.Prim.or64#) | Just r <- liftW64 or64# args+ -> reduce r+ $(namePat 'GHC.Prim.xor64#) | Just r <- liftW64 xor64# args+ -> reduce r+ $(namePat 'GHC.Prim.not64#) | [i] <- word64Literals' args+ -> let !(W64# a) = fromInteger i+ in reduce (Literal (Word64Literal (toInteger (W64# (not64# a)))))+ $(namePat 'GHC.Prim.uncheckedShiftL64#) | Just r <- liftW64I uncheckedShiftL64# args+ -> reduce r+ $(namePat 'GHC.Prim.uncheckedShiftRL64#) | Just r <- liftW64I uncheckedShiftRL64# args+ -> reduce r+ $(namePat 'GHC.Prim.word64ToInt64#) | [i] <- word64Literals' args+ -> let !(W64# a) = fromInteger i+ in reduce (Literal (Int64Literal (toInteger (I64# (word64ToInt64# a)))))+ $(namePat 'GHC.Prim.eqWord64#) | Just r <- liftW64RI eqWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.geWord64#) | Just r <- liftW64RI geWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.gtWord64#) | Just r <- liftW64RI gtWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.leWord64#) | Just r <- liftW64RI leWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.ltWord64#) | Just r <- liftW64RI ltWord64# args+ -> reduce r+ $(namePat 'GHC.Prim.neWord64#) | Just r <- liftW64RI neWord64# args+ -> reduce r+#endif+#endif++----------+-- Double#+----------+ $(namePat '(GHC.Prim.>##)) | Just r <- liftDDI (>##) args+ -> reduce r+ $(namePat '(GHC.Prim.>=##)) | Just r <- liftDDI (>=##) args+ -> reduce r+ $(namePat '(GHC.Prim.==##)) | Just r <- liftDDI (==##) args+ -> reduce r+ $(namePat '(GHC.Prim./=##)) | Just r <- liftDDI (/=##) args+ -> reduce r+ $(namePat '(GHC.Prim.<##)) | Just r <- liftDDI (<##) args+ -> reduce r+ $(namePat '(GHC.Prim.<=##)) | Just r <- liftDDI (<=##) args+ -> reduce r+ $(namePat '(GHC.Prim.+##)) | Just r <- liftDDD (+##) args+ -> reduce r+ $(namePat '(GHC.Prim.-##)) | Just r <- liftDDD (-##) args+ -> reduce r+ $(namePat '(GHC.Prim.*##)) | Just r <- liftDDD (*##) args+ -> reduce r+ $(namePat '(GHC.Prim./##)) | Just r <- liftDDD (/##) args+ -> reduce r++ $(namePat 'GHC.Prim.negateDouble#) | Just r <- liftDD negateDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.fabsDouble#) | Just r <- liftDD fabsDouble# args+ -> reduce r++ $(namePat 'GHC.Prim.double2Int#) | [i] <- doubleLiterals' args+ -> let !(D# a) = wordToDouble i+ r = double2Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# r+ $(namePat 'GHC.Prim.double2Float#)+ | [Lit (DoubleLiteral d)] <- args+ -> let !(D# a) = wordToDouble d+ r = double2Float# a+ in reduce . Literal . FloatLiteral . floatToWord $ F# r++ $(namePat 'GHC.Prim.expDouble#) | Just r <- liftDD expDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.logDouble#) | Just r <- liftDD logDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.sqrtDouble#) | Just r <- liftDD sqrtDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.sinDouble#) | Just r <- liftDD sinDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.cosDouble#) | Just r <- liftDD cosDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.tanDouble#) | Just r <- liftDD tanDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.asinDouble#) | Just r <- liftDD asinDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.acosDouble#) | Just r <- liftDD acosDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.atanDouble#) | Just r <- liftDD atanDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.sinhDouble#) | Just r <- liftDD sinhDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.coshDouble#) | Just r <- liftDD coshDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.tanhDouble#) | Just r <- liftDD tanhDouble# args+ -> reduce r++#if MIN_VERSION_ghc(8,7,0)+ $(namePat 'GHC.Prim.asinhDouble#) | Just r <- liftDD asinhDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.acoshDouble#) | Just r <- liftDD acoshDouble# args+ -> reduce r+ $(namePat 'GHC.Prim.atanhDouble#) | Just r <- liftDD atanhDouble# args+ -> reduce r+#endif++ $(namePat '(GHC.Prim.**##)) | Just r <- liftDDD (**##) args+ -> reduce r+-- decodeDouble_2Int# :: Double# -> (#Int#, Word#, Word#, Int##)+ $(namePat 'GHC.Prim.decodeDouble_2Int#) | [i] <- doubleLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = wordToDouble i+ !(# p, q, r, s #) = decodeDouble_2Int# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# p)+ , Left (Literal . WordLiteral . toInteger $ W# q)+ , Left (Literal . WordLiteral . toInteger $ W# r)+ , Left (Literal . IntLiteral . toInteger $ I# s)])+-- decodeDouble_Int64# :: Double# -> (# Int64#, Int# #)+ $(namePat 'GHC.Prim.decodeDouble_Int64#) | [i] <- doubleLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = wordToDouble i+ !(# p, q #) = decodeDouble_Int64# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++#if MIN_VERSION_ghc_prim(0,9,0)+ [ Left (Literal . Int64Literal . toInteger $ I64# p)+#else+ [ Left (Literal . IntLiteral . toInteger $ I64# p)+#endif+ , Left (Literal . IntLiteral . toInteger $ I# q)])++--------+-- Float+--------+ $(namePat 'GHC.Prim.gtFloat#) | Just r <- liftFFI gtFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.geFloat#) | Just r <- liftFFI geFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.eqFloat#) | Just r <- liftFFI eqFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.neFloat#) | Just r <- liftFFI neFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.ltFloat#) | Just r <- liftFFI ltFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.leFloat#) | Just r <- liftFFI leFloat# args+ -> reduce r++ $(namePat 'GHC.Prim.plusFloat#) | Just r <- liftFFF plusFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.minusFloat#) | Just r <- liftFFF minusFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.timesFloat#) | Just r <- liftFFF timesFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.divideFloat#) | Just r <- liftFFF divideFloat# args+ -> reduce r++ $(namePat 'GHC.Prim.negateFloat#) | Just r <- liftFF negateFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.fabsFloat#) | Just r <- liftFF fabsFloat# args+ -> reduce r++ $(namePat 'GHC.Prim.float2Int#) | [i] <- floatLiterals' args+ -> let !(F# a) = wordToFloat i+ r = float2Int# a+ in reduce . Literal . IntLiteral . toInteger $ I# r++ $(namePat 'GHC.Prim.expFloat#) | Just r <- liftFF expFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.logFloat#) | Just r <- liftFF logFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.sqrtFloat#) | Just r <- liftFF sqrtFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.sinFloat#) | Just r <- liftFF sinFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.cosFloat#) | Just r <- liftFF cosFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.tanFloat#) | Just r <- liftFF tanFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.asinFloat#) | Just r <- liftFF asinFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.acosFloat#) | Just r <- liftFF acosFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.atanFloat#) | Just r <- liftFF atanFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.sinhFloat#) | Just r <- liftFF sinhFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.coshFloat#) | Just r <- liftFF coshFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.tanhFloat#) | Just r <- liftFF tanhFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.powerFloat#) | Just r <- liftFFF powerFloat# args+ -> reduce r++ -- GHC.Float.asinh -- XXX: Very fragile+ -- $w$casinh is the Double specialisation of asinh+ -- $w$casinh1 is the Float specialisation of asinh+ "GHC.Float.$w$casinh" | Just r <- liftDD go args+ -> reduce r+ where go f = case asinh (D# f) of+ D# f' -> f'+ "GHC.Float.$w$casinh1" | Just r <- liftFF go args+ -> reduce r+ where go f = case asinh (F# f) of+ F# f' -> f'++#if MIN_VERSION_ghc(8,7,0)+ $(namePat 'GHC.Prim.asinhFloat#) | Just r <- liftFF asinhFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.acoshFloat#) | Just r <- liftFF acoshFloat# args+ -> reduce r+ $(namePat 'GHC.Prim.atanhFloat#) | Just r <- liftFF atanhFloat# args+ -> reduce r+#endif++ $(namePat 'GHC.Prim.float2Double#) | [i] <- floatLiterals' args+ -> let !(F# a) = wordToFloat i+ r = float2Double# a+ in reduce . Literal . DoubleLiteral . doubleToWord $ D# r+++ $(namePat 'GHC.Prim.newByteArray#)+ | [iV,PrimVal rwTy _ _] <- args+ , [i] <- intLiterals' [iV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ p = primCount mach+ lit = Literal (ByteArrayLiteral (fromList (List.genericReplicate i 0)))+ mbaTy = mkFunTy intPrimTy (last tyArgs)+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left (mkApps (Prim (PrimInfo (showt ''MutableByteArray#) mbaTy WorkNever SingleResult NoUnfolding))+ [Left (Literal . IntLiteral $ toInteger p)])+ ])+ in Just . setTerm newE $ primInsert p lit mach++ $(namePat 'GHC.Prim.setByteArray#)+ | [PrimVal _mbaTy _ [baV]+ ,offV,lenV,cV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,off,len,c] <- intLiterals' [baV,offV,lenV,cV]+ -> let Just (Literal (ByteArrayLiteral ba1)) =+ primLookup (fromInteger ba) mach+ !(I# off') = fromInteger off+ !(I# len') = fromInteger len+ !(I# c') = fromInteger c+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ svoid (setByteArray# mba off' len' c')+ BA.unsafeFreezeByteArray (BA.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach++ $(namePat 'GHC.Prim.writeWordArray#)+ | [PrimVal _mbaTy _ [baV]+ ,iV,wV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,i] <- intLiterals' [baV,iV]+ , [w] <- wordLiterals' [wV]+ -> let Just (Literal (ByteArrayLiteral ba1)) =+ primLookup (fromInteger ba) mach+ !(I# i') = fromInteger i+ !(W# w') = fromIntegral w+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ svoid (writeWordArray# mba i' w')+ BA.unsafeFreezeByteArray (BA.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach++ $(namePat 'GHC.Prim.unsafeFreezeByteArray#)+ | [PrimVal _mbaTy _ [baV]+ ,PrimVal rwTy _ _+ ] <- args+ , [ba] <- intLiterals' [baV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Just ba' = primLookup (fromInteger ba) mach+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left ba'])++ $(namePat 'GHC.Prim.sizeofByteArray#)+ | [Lit (ByteArrayLiteral ba)] <- args+ -> reduce (Literal (IntLiteral (toInteger (BA.sizeofByteArray ba))))++ $(namePat 'GHC.Prim.indexWordArray#)+ | [Lit (ByteArrayLiteral (BA.ByteArray ba)),iV] <- args+ , [i] <- intLiterals' [iV]+ -> let !(I# i') = fromInteger i+ !w = indexWordArray# ba i'+ in reduce (Literal (WordLiteral (toInteger (W# w))))++ -- XXX: Primitive does not exist?+ "GHC.Prim.getSizeofMutBigNat#"+ | [PrimVal _mbaTy _ [baV]+ ,PrimVal rwTy _ _+ ] <- args+ , [ba] <- intLiterals' [baV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Just (Literal (ByteArrayLiteral ba')) = primLookup (fromInteger ba) mach+ lit = Literal (IntLiteral (toInteger (BA.sizeofByteArray ba')))+ in reduce $ mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left lit])++ $(namePat 'GHC.Prim.resizeMutableByteArray#)+ | [PrimVal mbaTy _ [baV]+ ,iV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,i] <- intLiterals' [baV,iV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ p = primCount mach+ Just (Literal (ByteArrayLiteral ba1))+ = primLookup (fromInteger ba) mach+ !(I# i') = fromInteger i+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ mba' <- IO (\s -> case resizeMutableByteArray# mba i' s of+ (# s', mba' #) -> (# s', BA.MutableByteArray mba' #))+ BA.unsafeFreezeByteArray mba'+ ba3 = Literal (ByteArrayLiteral ba2)+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left (mkApps (Prim mbaTy)+ [Left (Literal . IntLiteral $ toInteger p)])+ ])+ in Just . setTerm newE $ primInsert p ba3 mach++ $(namePat 'GHC.Prim.shrinkMutableByteArray#)+ | [PrimVal _mbaTy _ [baV]+ ,lenV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,len] <- intLiterals' [baV,lenV]+ -> let Just (Literal (ByteArrayLiteral ba1)) =+ primLookup (fromInteger ba) mach+ !(I# len') = fromInteger len+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ svoid (shrinkMutableByteArray# mba len')+ BA.unsafeFreezeByteArray (BA.MutableByteArray mba)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach++ $(namePat 'GHC.Prim.copyByteArray#)+ | [Lit (ByteArrayLiteral (BA.ByteArray src_ba))+ ,src_offV+ ,PrimVal _mbaTy _ [dst_mbaV]+ ,dst_offV, nV+ ,PrimVal rwTy _ _+ ] <- args+ , [src_off,dst_mba,dst_off,n] <- intLiterals' [src_offV,dst_mbaV,dst_offV,nV]+ -> let Just (Literal (ByteArrayLiteral dst_ba)) =+ primLookup (fromInteger dst_mba) mach+ !(I# src_off') = fromInteger src_off+ !(I# dst_off') = fromInteger dst_off+ !(I# n') = fromInteger n+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray dst_mba1 <- BA.unsafeThawByteArray dst_ba+ svoid (copyByteArray# src_ba src_off' dst_mba1 dst_off' n')+ BA.unsafeFreezeByteArray (BA.MutableByteArray dst_mba1)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger dst_mba) ba3 mach++ $(namePat 'GHC.Prim.readWordArray#)+ | [PrimVal _mbaTy _ [baV]+ ,offV+ ,PrimVal rwTy _ _+ ] <- args+ , [ba,off] <- intLiterals' [baV,offV]+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ Just (Literal (ByteArrayLiteral ba1)) =+ primLookup (fromInteger ba) mach+ !(I# off') = fromInteger off+ w = unsafeDupablePerformIO $ do+ BA.MutableByteArray mba <- BA.unsafeThawByteArray ba1+ IO (\s -> case readWordArray# mba off' s of+ (# s', w' #) -> (# s', W# w' #))+ newE = mkApps (Data tupDc) (map Right tyArgs +++ [Left (Prim rwTy)+ ,Left (Literal (WordLiteral (toInteger w)))+ ])+ in reduce newE++ $(namePat 'GHC.Prim.copyAddrToByteArray#)+ | [ Lit (StringLiteral addr)+ , PrimVal _mbaTy _ [dst_mbaV]+ , offV, lenV+ , PrimVal rwTy _ _+ ] <- args+ , [off,len,dst_mba] <- intLiterals' [offV, lenV, dst_mbaV]+ -> let Just (Literal (ByteArrayLiteral dst_ba)) =+ primLookup (fromInteger dst_mba) mach+ !(I# off') = fromInteger off+ !(I# len') = fromInteger len+ !(BS.PS (ForeignPtr addr' _) _ _) = BS.packChars addr+ ba2 = unsafeDupablePerformIO $ do+ BA.MutableByteArray dst_mba1 <- BA.unsafeThawByteArray dst_ba+ svoid (copyAddrToByteArray# addr' dst_mba1 off' len')+ BA.unsafeFreezeByteArray (BA.MutableByteArray dst_mba1)+ ba3 = Literal (ByteArrayLiteral ba2)+ in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger dst_mba) ba3 mach++-- decodeFloat_Int# :: Float# -> (#Int#, Int##)+ $(namePat 'GHC.Prim.decodeFloat_Int#) | [i] <- floatLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(F# a) = wordToFloat i+ !(# p, q #) = decodeFloat_Int# a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal . IntLiteral . toInteger $ I# p)+ , Left (Literal . IntLiteral . toInteger $ I# q)])++ $(namePat 'GHC.Prim.tagToEnum#)+ | [ConstTy (TyCon tcN)] <- tys+ , [Lit (IntLiteral i)] <- args+ -> let dc = do { tc <- UniqMap.lookup tcN tcm+ ; let dcs = tyConDataCons tc+ ; List.find ((== (i+1)) . toInteger . dcTag) dcs+ }+ in (\e -> setTerm (Data e) mach) <$> dc++#if MIN_VERSION_ghc_prim(0,12,0)+ $(namePat 'GHC.PrimopWrappers.dataToTagSmall#)+ | [DC dc _] <- args+ -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))++ $(namePat 'GHC.PrimopWrappers.dataToTagLarge#)+ | [DC dc _] <- args+ -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))+#endif+#if MIN_VERSION_ghc(9,10,0)+ $(namePat 'GHC.Prim.dataToTagSmall#)+ | [DC dc _] <- args+ -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))+ $(namePat 'GHC.Prim.dataToTagLarge#)+ | [DC dc _] <- args+ -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))+ $(namePat 'GHC.Base.dataToTag#)+ | [DC dc _] <- args+ -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))+#else+ $(namePat 'GHC.Prim.dataToTag#)+ | [DC dc _] <- args+ -> reduce (Literal (IntLiteral (toInteger (dcTag dc - 1))))+#endif++ $(namePat 'GHC.Classes.eqInt) | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))++ $(namePat 'GHC.Classes.neInt) | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++ $(namePat 'GHC.Classes.leInt) | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++ $(namePat 'GHC.Classes.ltInt) | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))++ $(namePat 'GHC.Classes.geInt) | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))++ $(namePat 'GHC.Classes.gtInt) | Just (i,j) <- intCLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))++ $(namePat '(GHC.Classes.&&))+ | [ lArg , rArg ] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ -- evaluation of the arguments is deferred until the evaluation of the ghcPrimUnwindWith+ -- to make `&&` lazy in both arguments+ , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf eval tcm True (setTerm (valToTerm lArg) $ stackClear mach)+ , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf eval tcm True (setTerm (valToTerm rArg) $ stackClear mach1)+ -> case [ lArgWHNF, rArgWHNF ] of+ [ Data lCon, Data rCon ] ->+ Just $ mach2+ { mStack = mStack mach+ , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon && isTrueDC rCon)+ }++ [ Data lCon, _ ]+ | isTrueDC lCon -> reduce rArgWHNF+ | otherwise -> reduce (boolToBoolLiteral tcm ty False)++ [ _, Data rCon ]+ | isTrueDC rCon -> reduce lArgWHNF+ | otherwise -> reduce (boolToBoolLiteral tcm ty False)++ _ -> Nothing++ $(namePat '(GHC.Classes.||))+ | [ lArg , rArg ] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ -- evaluation of the arguments is deferred until the evaluation of the ghcPrimUnwindWith+ -- to make `||` lazy in both arguments+ , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf eval tcm True (setTerm (valToTerm lArg) $ stackClear mach)+ , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf eval tcm True (setTerm (valToTerm rArg) $ stackClear mach1)+ -> case [ lArgWHNF, rArgWHNF ] of+ [ Data lCon, Data rCon ] ->+ Just $ mach2+ { mStack = mStack mach+ , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon || isTrueDC rCon)+ }++ [ Data lCon, _ ]+ | isFalseDC lCon -> reduce rArgWHNF+ | otherwise -> reduce (boolToBoolLiteral tcm ty True)++ [ _, Data rCon ]+ | isFalseDC rCon -> reduce lArgWHNF+ | otherwise -> reduce (boolToBoolLiteral tcm ty True)++ _ -> Nothing++ $(namePat 'GHC.Classes.divInt#) | Just (i,j) <- intLiterals args+ -> reduce (integerToIntLiteral (i `div` j))++ -- modInt# :: Int# -> Int# -> Int#+ $(namePat 'GHC.Classes.modInt#)+ | [dividend, divisor] <- intLiterals' args+ ->+ if divisor == 0 then+ let iTy = snd (splitFunForallTy ty) in+ reduce (TyApp (Prim NP.undefined) iTy)+ else+ reduce (Literal (IntLiteral (dividend `mod` divisor)))++ $(namePat 'GHC.Classes.not)+ | [DC bCon _] <- args+ -> reduce (boolToBoolLiteral tcm ty (nameOcc (dcName bCon) == showt 'False))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerLogBase#)+ | Just (a,b) <- integerLiterals args+ , Just c <- flogBase a b+ -> (reduce . Literal . WordLiteral . toInteger) c++#if MIN_VERSION_base(4,16,0)+ $(namePat 'GHC.Float.integerToFloat#)+#else+ $(namePat 'GHC.Num.integerToFloat#)+#endif+ | [v] <- args+ , Just i <- integerLiteral v+ -> reduce . Literal . FloatLiteral . floatToWord $ F# (integerToFloat# i)++#if MIN_VERSION_base(4,16,0)+ $(namePat 'GHC.Float.integerToDouble#)+#else+ $(namePat 'GHC.Num.integerToDouble#)+#endif+ | [v] <- args+ , Just i <- integerLiteral v+ -> reduce . Literal . DoubleLiteral . doubleToWord $ D# (integerToDouble# i)++ $(namePat 'GHC.Num.naturalLogBase#)+ | Just (a,b) <- naturalLiterals args+ , Just c <- flogBase a b+ -> (reduce . Literal . WordLiteral . toInteger) c+#else+ $(namePat 'GHC.Integer.Logarithms.integerLogBase#)+ | Just (a,b) <- integerLiterals args+ , Just c <- flogBase a b+ -> (reduce . Literal . IntLiteral . toInteger) c+#endif++#if !MIN_VERSION_base(4,15,0)+ "GHC.Integer.Type.smallInteger"+ | [Lit (IntLiteral i)] <- args+ -> reduce (Literal (IntegerLiteral i))+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerToInt#)+#else+ "GHC.Integer.Type.integerToInt"+#endif+ | [i] <- integerLiterals' args+ -> reduce (integerToIntLiteral i)++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerDecodeDouble#) -- :: Double# -> (#Integer, Int##)+#else+ "GHC.Integer.Type.decodeDoubleInteger" -- :: Double# -> (#Integer, Int##)+#endif+ | [Lit (DoubleLiteral i)] <- args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ !(D# a) = wordToDouble i+ !(# b, c #) = decodeDoubleInteger a+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (integerToIntegerLiteral b)+ , Left (integerToIntLiteral . toInteger $ I# c)])++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerEncodeDouble#) -- :: Integer -> Int# -> Double+#else+ "GHC.Integer.Type.encodeDoubleInteger" -- :: Integer -> Int# -> Double+#endif+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> let !(I# k') = fromInteger j+ r = encodeDoubleInteger i k'+ in reduce . Literal . DoubleLiteral . doubleToWord $ D# r++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerEncodeFloat#)+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> let !(I# k') = fromInteger j+ r = integerEncodeFloat# i k'+ in reduce . Literal . FloatLiteral . floatToWord $ F# r+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerQuotRem#) -- :: Integer -> Integer -> (#Integer, Integer#)+#else+ "GHC.Integer.Type.quotRemInteger" -- :: Integer -> Integer -> (#Integer, Integer#)+#endif+ | [i, j] <- integerLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem i j+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (integerToIntegerLiteral q)+ , Left $ catchDivByZero (integerToIntegerLiteral r)])++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerAdd)+#else+ "GHC.Integer.Type.plusInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i+j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerSub)+#else+ "GHC.Integer.Type.minusInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i-j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerMul)+#else+ "GHC.Integer.Type.timesInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (integerToIntegerLiteral (i*j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerNegate)+#else+ "GHC.Integer.Type.negateInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (integerToIntegerLiteral (negate i))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerDiv)+#else+ "GHC.Integer.Type.divInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `div` j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerMod)+#else+ "GHC.Integer.Type.modInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `mod` j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerQuot)+#else+ "GHC.Integer.Type.quotInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `quot` j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerRem)+#else+ "GHC.Integer.Type.remInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce $ catchDivByZero (integerToIntegerLiteral (i `rem` j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerDivMod#)+#else+ "GHC.Integer.Type.divModInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> let (_,tyView -> TyConApp ubTupTcNm [liftedKi,_,intTy,_]) = splitFunForallTy ty+ (Just ubTupTc) = UniqMap.lookup ubTupTcNm tcm+ [ubTupDc] = tyConDataCons ubTupTc+ (d,m) = divMod i j+ in reduce $+ mkApps (Data ubTupDc) [ Right liftedKi, Right liftedKi+ , Right intTy, Right intTy+ , Left $ catchDivByZero (Literal (IntegerLiteral d))+ , Left $ catchDivByZero (Literal (IntegerLiteral m))+ ]++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerGt)+#else+ "GHC.Integer.Type.gtInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerGe)+#else+ "GHC.Integer.Type.geInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerEq)+#else+ "GHC.Integer.Type.eqInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerNe)+#else+ "GHC.Integer.Type.neqInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerLt)+#else+ "GHC.Integer.Type.ltInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerLe)+#else+ "GHC.Integer.Type.leInteger"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerGt#)+#else+ "GHC.Integer.Type.gtInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i > j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerGe#)+#else+ "GHC.Integer.Type.geInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i >= j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerEq#)+#else+ "GHC.Integer.Type.eqInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i == j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerNe#)+#else+ "GHC.Integer.Type.neqInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i /= j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerLt#)+#else+ "GHC.Integer.Type.ltInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i < j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerLe#)+#else+ "GHC.Integer.Type.leInteger#"+#endif+ | Just (i,j) <- integerLiterals args+ -> reduce (boolToIntLiteral (i <= j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerCompare)+#else+ "GHC.Integer.Type.compareInteger" -- :: Integer -> Integer -> Ordering+#endif+ | [i, j] <- integerLiterals' args+ -> let -- Get the required result type (viewed as an applied type constructor name)+ (_,tyView -> TyConApp tupTcNm []) = splitFunForallTy ty+ -- Find the type constructor from the name+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ -- Get the data constructors of that type+ -- The type is 'Ordering', so they are: 'LT', 'EQ', 'GT'+ [ltDc, eqDc, gtDc] = tyConDataCons tupTc+ -- Do the actual compile-time evaluation+ ordVal = compareInteger i j+ in reduce $ case ordVal of+ LT -> Data ltDc+ EQ -> Data eqDc+ GT -> Data gtDc++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerShiftR#)+ | [iV, Lit (WordLiteral j)] <- args+#else+ "GHC.Integer.Type.shiftRInteger"+ | [iV, Lit (IntLiteral j)] <- args+#endif+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral (i `shiftR` fromInteger j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerShiftL#)+ | [iV, Lit (WordLiteral j)] <- args+#else+ "GHC.Integer.Type.shiftLInteger"+ | [iV, Lit (IntLiteral j)] <- args+#endif+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral (i `shiftL` fromInteger j))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerFromWord#)+#else+ "GHC.Integer.Type.wordToInteger"+#endif+ | [Lit (WordLiteral w)] <- args+ -> reduce (Literal (IntegerLiteral w))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerToWord#)+#else+ "GHC.Integer.Type.integerToWord"+#endif+ | [i] <- integerLiterals' args+ -> reduce (integerToWordLiteral i)++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerTestBit#) -- :: Integer -> Int# -> Int#+ | [Lit (IntegerLiteral i), Lit (WordLiteral j)] <- args+ -> reduce (boolToIntLiteral (testBit i (fromInteger j)))+#else+ "GHC.Integer.Type.testBitInteger" -- :: Integer -> Int# -> Bool+ | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+ -> reduce (boolToBoolLiteral tcm ty (testBit i (fromInteger j)))+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.NS)+ | [Lit (WordLiteral w)] <- args+ -> reduce (Literal (NaturalLiteral w))+ $(namePat 'GHC.Num.NB)+ | [Lit (ByteArrayLiteral (BA.ByteArray ba))] <- args+ -> reduce (Literal (NaturalLiteral (IP ba)))+ | [Lit l] <- args+ -> error ("NB: " <> show l)+ $(namePat 'GHC.Num.Integer.IS)+ | [Lit (IntLiteral i)] <- args+ -> reduce (Literal (IntegerLiteral i))+ $(namePat 'GHC.Num.Integer.IP)+ | [Lit (ByteArrayLiteral (BA.ByteArray ba))] <- args+ -> reduce (Literal (IntegerLiteral (IP ba)))+ | [Lit l] <- args+ -> error ("IP: " <> show l)+ $(namePat 'GHC.Num.Integer.IN)+ | [Lit (ByteArrayLiteral (BA.ByteArray ba))] <- args+ -> reduce (Literal (IntegerLiteral (IN ba)))+ | [Lit l] <- args+ -> error ("IN: " <> show l)+#else+ $(namePat 'GHC.Natural.NatS#)+ | [Lit (WordLiteral w)] <- args+ -> reduce (Literal (NaturalLiteral w))+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerFromNatural)+#else+ $(namePat 'GHC.Natural.naturalToInteger)+#endif+ | [i] <- naturalLiterals' args+ -> reduce (Literal (IntegerLiteral (toInteger i)))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerToNatural)+#else+ $(namePat 'GHC.Natural.naturalFromInteger)+#endif+ | [i] <- integerLiterals' args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy i id)++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerToNaturalClamp)+ | [i] <- integerLiterals' args+ -> if i < 0 then+ reduce (naturalToNaturalLiteral 0)+ else+ reduce (naturalToNaturalLiteral (fromInteger i))++ $(namePat 'GHC.Num.Integer.integerToNaturalThrow)+ | [i] <- integerLiterals' args+ -> let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy i id)+#endif++#if MIN_VERSION_base(4,17,0) || WORD_SIZE_IN_BITS < 64+ $(namePat 'GHC.Num.Integer.integerToInt64#)+ | [i] <- integerLiterals' args+ -> reduce (integerToInt64Literal i)++ $(namePat 'GHC.Num.Integer.integerToWord64#)+ | [i] <- integerLiterals' args+ -> reduce (integerToWord64Literal i)++#if MIN_VERSION_base(4,17,0)+ $(namePat 'GHC.Num.Integer.integerFromWord64#)+ | [w] <- word64Literals' args+ -> reduce (Literal (IntegerLiteral w))+#endif+#endif++#if !MIN_VERSION_base(4,15,0)+ -- GHC.shiftLNatural --- XXX: Fragile worker of GHC.shiflLNatural+ "GHC.Natural.$wshiftLNatural"+ | [nV,iV] <- args+ , [n] <- naturalLiterals' [nV]+ , [i] <- fromInteger <$> intLiterals' [iV]+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy n ((flip shiftL) i))+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.naturalAdd)+#else+ $(namePat 'GHC.Natural.plusNatural)+#endif+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j (+))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.naturalMul)+#else+ $(namePat 'GHC.Natural.timesNatural)+#endif+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j (*))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Natural.naturalSubUnsafe)+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->+ naturalToNaturalLiteral (naturalSubUnsafe i' j')))++ $(namePat 'GHC.Num.naturalSubThrow)+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->+ case minusNaturalMaybe i' j' of+ Nothing -> checkNaturalRange1 nTy (-1) id+ Just n -> naturalToNaturalLiteral n))+#else+ $(namePat 'GHC.Natural.minusNatural)+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange nTy [i, j] (\[i', j'] ->+ case minusNaturalMaybe i' j' of+ Nothing -> checkNaturalRange1 nTy (-1) id+ Just n -> naturalToNaturalLiteral n))+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.naturalFromWord#)+#else+ $(namePat 'GHC.Natural.wordToNatural#)+#endif+ | [Lit (WordLiteral w)] <- args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange1 nTy w id)++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.naturalToWord#)+ | [i] <- naturalLiterals' args+ -> reduce (integerToWordLiteral i)++ $(namePat 'GHC.Num.naturalQuot)+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j quot)++ $(namePat 'GHC.Num.naturalRem)+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j rem)+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.naturalQuotRem#) -- :: Natural -> Natural -> (#Natural, Natural#)+ | [i, j] <- naturalLiterals' args+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ (q,r) = quotRem (fromInteger i) (fromInteger j)+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left $ catchDivByZero (naturalToNaturalLiteral q)+ , Left $ catchDivByZero (naturalToNaturalLiteral r)])+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.naturalGcd)+#else+ $(namePat 'GHC.Natural.gcdNatural)+#endif+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j gcd)++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.naturalLcm)+ | Just (i,j) <- naturalLiterals args+ ->+ let nTy = snd (splitFunForallTy ty) in+ reduce (checkNaturalRange2 nTy i j lcm)+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.naturalGt#)+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i > j))++ $(namePat 'GHC.Num.naturalGe#)+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i >= j))++ $(namePat 'GHC.Num.naturalEq#)+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i == j))++ $(namePat 'GHC.Num.naturalNe#)+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i /= j))++ $(namePat 'GHC.Num.naturalLt#)+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i < j))++ $(namePat 'GHC.Num.naturalLe#)+ | Just (i,j) <- naturalLiterals args+ -> reduce (boolToIntLiteral (i <= j))++ $(namePat 'GHC.Num.naturalShiftL#)+ | [iV, Lit (WordLiteral j)] <- args+ , [i] <- naturalLiterals' [iV]+ -> reduce (naturalToNaturalLiteral (fromInteger (i `shiftL` fromInteger j)))++ $(namePat 'GHC.Num.naturalShiftR#)+ | [iV, Lit (WordLiteral j)] <- args+ , [i] <- naturalLiterals' [iV]+ -> reduce (naturalToNaturalLiteral (fromInteger (i `shiftR` fromInteger j)))++ $(namePat 'GHC.Num.naturalCompare)+ | [i, j] <- naturalLiterals' args+ -> let -- Get the required result type (viewed as an applied type constructor name)+ (_,tyView -> TyConApp tupTcNm []) = splitFunForallTy ty+ -- Find the type constructor from the name+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ -- Get the data constructors of that type+ -- The type is 'Ordering', so they are: 'LT', 'EQ', 'GT'+ [ltDc, eqDc, gtDc] = tyConDataCons tupTc+ -- Do the actual compile-time evaluation+ ordVal = compareInteger i j+ in reduce $ case ordVal of+ LT -> Data ltDc+ EQ -> Data eqDc+ GT -> Data gtDc++ $(namePat 'GHC.Num.naturalSignum)+ | [i] <- naturalLiterals' args+ -> reduce (Literal (NaturalLiteral (signum i)))++ "GHC.Num.Natural.$wnaturalSignum"+ | [i] <- naturalLiterals' args+ -> reduce (Literal (WordLiteral (signum i)))+#endif++ -- GHC.Real.^ -- XXX: Very fragile+ -- ^_f, $wf, $wf1 are specialisations of the internal function f in the implementation of (^) in GHC.Real+ "GHC.Real.^_f" -- :: Integer -> Integer -> Integer+ | [i,j] <- integerLiterals' args+ -> reduce (integerToIntegerLiteral $ i ^ j)+ "GHC.Real.$wf" -- :: Integer -> Int# -> Integer+ | [iV, Lit (IntLiteral j)] <- args+ , [i] <- integerLiterals' [iV]+ -> reduce (integerToIntegerLiteral $ i ^ j)+ "GHC.Real.$wf1" -- :: Int# -> Int# -> Int#+ | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args+ -> reduce (integerToIntLiteral $ i ^ j)+ "GHC.Internal.Real.^_$s$spowImpl2" -- :: Int# -> Integer -> Integer+ | [intLiteral -> Just j, integerLiteral -> Just i] <- args+ -> reduce (integerToIntLiteral $ i ^ j)+ "GHC.Internal.Real.$w$spowImpl" -- :: Integer -> Int# -> Integer+ | [integerLiteral -> Just i, intLiteral -> Just j] <- args+ -> reduce (integerToIntLiteral $ i ^ j)+ "GHC.Internal.Real.$w$spowImpl1" -- :: Int# -> Int# -> Integer+ | [intLiteral -> Just i, intLiteral -> Just j] <- args+ -> reduce (integerToIntLiteral $ i ^ j)+ "GHC.Real.^_$s$spowImpl2" -- :: Int# -> Integer -> Integer+ | [intLiteral -> Just j, integerLiteral -> Just i] <- args+ -> reduce (integerToIntLiteral $ i ^ j)+ "GHC.Real.$w$spowImpl" -- :: Integer -> Int# -> Integer+ | [integerLiteral -> Just i, intLiteral -> Just j] <- args+ -> reduce (integerToIntLiteral $ i ^ j)+ "GHC.Real.$w$spowImpl1" -- :: Int# -> Int# -> Integer+ | [intLiteral -> Just i, intLiteral -> Just j] <- args+ -> reduce (integerToIntLiteral $ i ^ j)+ "GHC.Real.^_$sf2" -- :: Int# -> Integer -> Integer+ | [intLiteral -> Just j, integerLiteral -> Just i] <- args+ -> reduce (integerToIntLiteral $ i ^ j)++ -- Type level ^ -- XXX: Very fragile+ -- These is are specialized versions of ^_f, named by some combination of ghc and singletons.+ "Data.Singletons.TypeLits.Internal.$fSingI->^@#@$_f" -- ghc-8.6.5, singletons-2.5.1+ | [i,j] <- naturalLiterals' args+ -> reduce (Literal (NaturalLiteral (i ^ j)))+ "Data.Singletons.TypeLits.Internal.%^_f" -- ghc-8.8.1, singletons-2.6+ | [i,j] <- naturalLiterals' args+ -> reduce (Literal (NaturalLiteral (i ^ j)))++ -- XXX: Does it make sense to match on a @NaturalLiteral@ here?+ $(namePat 'GHC.TypeLits.natVal)+ | [Lit (NaturalLiteral n), _] <- args+ -> reduce (integerToIntegerLiteral n)++ $(namePat 'GHC.TypeNats.natVal)+ | [Lit (NaturalLiteral n), _] <- args+ -> reduce (Literal (NaturalLiteral n))++ $(namePat 'GHC.TypeNats.someNatVal)+ | [Lit (NaturalLiteral n)] <- args+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkSomeNat tcm n resTy)++ -- XXX: Does it make sense to match on a @NaturalLiteral@ here?+ $(namePat 'GHC.TypeLits.someNatVal)+ | [Lit (NaturalLiteral n)] <- args+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkSomeNat tcm n resTy)++ $(namePat 'GHC.Types.I#)+ | isSubj+ , [Lit (IntLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])++ $(namePat 'GHC.Int.I8#)+ | isSubj+#if MIN_VERSION_base(4,16,0)+ , [Lit (Int8Literal i)] <- args+#else+ , [Lit (IntLiteral i)] <- args+#endif+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intDc] = tyConDataCons intTc+#if MIN_VERSION_base(4,16,0)+ in reduce (mkApps (Data intDc) [Left (Literal (Int8Literal i))])+#else+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+#endif+ $(namePat 'GHC.Int.I16#)+ | isSubj+#if MIN_VERSION_base(4,16,0)+ , [Lit (Int16Literal i)] <- args+#else+ , [Lit (IntLiteral i)] <- args+#endif+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intDc] = tyConDataCons intTc+#if MIN_VERSION_base(4,16,0)+ in reduce (mkApps (Data intDc) [Left (Literal (Int16Literal i))])+#else+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+#endif+ $(namePat 'GHC.Int.I32#)+ | isSubj+#if MIN_VERSION_base(4,16,0)+ , [Lit (Int32Literal i)] <- args+#else+ , [Lit (IntLiteral i)] <- args+#endif+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intDc] = tyConDataCons intTc+#if MIN_VERSION_base(4,16,0)+ in reduce (mkApps (Data intDc) [Left (Literal (Int32Literal i))])+#else+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+#endif+ $(namePat 'GHC.Int.I64#)+ | isSubj+#if MIN_VERSION_base(4,16,0)+ , [Lit (Int64Literal i)] <- args+#else+ , [Lit (IntLiteral i)] <- args+#endif+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intDc] = tyConDataCons intTc+#if MIN_VERSION_base(4,16,0)+ in reduce (mkApps (Data intDc) [Left (Literal (Int64Literal i))])+#else+ in reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+#endif++ $(namePat 'GHC.Word.W8#)+ | isSubj+#if MIN_VERSION_base(4,16,0)+ , [Lit (Word8Literal c)] <- args+#else+ , [Lit (WordLiteral c)] <- args+#endif+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = UniqMap.lookup wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+#if MIN_VERSION_base(4,16,0)+ in reduce (mkApps (Data wordDc) [Left (Literal (Word8Literal c))])+#else+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+#endif+ $(namePat 'GHC.Word.W16#)+ | isSubj+#if MIN_VERSION_base(4,16,0)+ , [Lit (Word16Literal c)] <- args+#else+ , [Lit (WordLiteral c)] <- args+#endif+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = UniqMap.lookup wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+#if MIN_VERSION_base(4,16,0)+ in reduce (mkApps (Data wordDc) [Left (Literal (Word16Literal c))])+#else+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+#endif+ $(namePat 'GHC.Word.W32#)+ | isSubj+#if MIN_VERSION_base(4,16,0)+ , [Lit (Word32Literal c)] <- args+#else+ , [Lit (WordLiteral c)] <- args+#endif+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = UniqMap.lookup wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+#if MIN_VERSION_base(4,16,0)+ in reduce (mkApps (Data wordDc) [Left (Literal (Word32Literal c))])+#else+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+#endif+ $(namePat 'GHC.Word.W64#)+ | isSubj+#if MIN_VERSION_base(4,16,0)+ , [Lit (Word64Literal c)] <- args+#else+ , [Lit (WordLiteral c)] <- args+#endif+ -> let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = UniqMap.lookup wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+#if MIN_VERSION_base(4,16,0)+ in reduce (mkApps (Data wordDc) [Left (Literal (Word64Literal c))])+#else+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+#endif++ $(namePat 'GHC.Types.W#)+ | isSubj+ , [Lit (WordLiteral i)] <- args+ -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intDc] = tyConDataCons intTc+ in reduce (mkApps (Data intDc) [Left (Literal (WordLiteral i))])++ "GHC.Float.$w$sfromRat''" -- XXX: Very fragile+ | [Lit (IntLiteral _minEx)+ ,Lit (IntLiteral matDigs)+ ,nV+ ,dV] <- args+ , [n,d] <- integerLiterals' [nV,dV]+ -> case fromInteger matDigs of+ matDigs'+ | matDigs' == floatDigits (undefined :: Float)+ -> reduce (Literal (FloatLiteral (floatToWord (fromRational (n :% d)))))+ | matDigs' == floatDigits (undefined :: Double)+ -> reduce (Literal (DoubleLiteral (doubleToWord (fromRational (n :% d)))))+ _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"++ "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile+ | [Lit (IntLiteral _minEx)+ ,Lit (IntLiteral matDigs)+ ,nV+ ,dV] <- args+ , [n,d] <- integerLiterals' [nV,dV]+ -> case fromInteger matDigs of+ matDigs'+ | matDigs' == floatDigits (undefined :: Float)+ -> reduce (Literal (FloatLiteral (floatToWord (fromRational (n :% d)))))+ | matDigs' == floatDigits (undefined :: Double)+ -> reduce (Literal (DoubleLiteral (doubleToWord (fromRational (n :% d)))))+ _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerSignum#)+#else+ "GHC.Integer.Type.$wsignumInteger" -- XXX: Not super-fragile, but still..+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntLiteral (signum i)))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerSignum)+#else+ "GHC.Integer.Type.signumInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (signumInteger i)))++#if MIN_VERSION_base(4,15,0)+ "GHC.Num.Integer.$wintegerSignum"+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntLiteral (signum i)))+#endif++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerAbs)+#else+ "GHC.Integer.Type.absInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (absInteger i)))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerBit#)+ | [i] <- wordLiterals' args+#else+ "GHC.Integer.Type.bitInteger"+ | [i] <- intLiterals' args+#endif+ -> reduce (Literal (IntegerLiteral (bit (fromInteger i))))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerComplement)+#else+ "GHC.Integer.Type.complementInteger"+#endif+ | [i] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (complementInteger i)))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerOr)+#else+ "GHC.Integer.Type.orInteger"+#endif+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (orInteger i j)))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerXor)+#else+ "GHC.Integer.Type.xorInteger"+#endif+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (xorInteger i j)))++#if MIN_VERSION_base(4,15,0)+ $(namePat 'GHC.Num.Integer.integerAnd)+#else+ "GHC.Integer.Type.andInteger"+#endif+ | [i, j] <- integerLiterals' args+ -> reduce (Literal (IntegerLiteral (andInteger i j)))++#if !MIN_VERSION_base(4,15,0)+ "GHC.Integer.Type.doubleFromInteger"+ | [i] <- integerLiterals' args+ -> reduce (Literal (DoubleLiteral (doubleToWord (fromInteger i))))+#endif++#if MIN_VERSION_base(4,17,0)+ "GHC.Num.Integer.$wintegerFromInt64#"+ | [i] <- int64Literals' args+ -> reduce . Literal $ IntLiteral i+#endif++ $(namePat 'GHC.Base.eqString)+ | [PrimVal _ _ [Lit (StringLiteral s1)]+ ,PrimVal _ _ [Lit (StringLiteral s2)]+ ] <- args+ -> reduce (boolToBoolLiteral tcm ty (s1 == s2))+ | otherwise -> error (show args)++ $(namePat 'GHC.Base.quotInt)+ | [ DC intDc [Left (Literal (IntLiteral i))]+ , DC _ [Left (Literal (IntLiteral j))]+ ] <- args+ -> reduce (App (Data intDc) (Literal (IntLiteral (i `quot` j))))++ $(namePat 'GHC.Base.remInt)+ | [ DC intDc [Left (Literal (IntLiteral i))]+ , DC _ [Left (Literal (IntLiteral j))]+ ] <- args+ -> reduce (App (Data intDc) (Literal (IntLiteral (i `rem` j))))++ $(namePat 'GHC.Base.divInt)+ | [ DC intDc [Left (Literal (IntLiteral i))]+ , DC _ [Left (Literal (IntLiteral j))]+ ] <- args+ -> reduce (App (Data intDc) (Literal (IntLiteral (i `div` j))))+++ $(namePat 'GHC.Base.modInt)+ | [ DC intDc [Left (Literal (IntLiteral i))]+ , DC _ [Left (Literal (IntLiteral j))]+ ] <- args+ -> reduce (App (Data intDc) (Literal (IntLiteral (i `mod` j))))++ $(namePat 'Clash.Class.BitPack.Internal.packDouble#) -- :: Double -> BitVector 64+ | [DC _ [Left arg]] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach2@Machine{mStack=[],mTerm=Literal (DoubleLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in Just $ mach2+ { mStack = mStack mach+ , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Word64 -> BitVector 64) i)+ }++ $(namePat 'Clash.Class.BitPack.Internal.packFloat#) -- :: Float -> BitVector 32+ | [DC _ [Left arg]] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach2@Machine{mStack=[],mTerm=Literal (FloatLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in Just $ mach2+ { mStack = mStack mach+ , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Word32 -> BitVector 32) i)+ }++ $(namePat 'Clash.Class.BitPack.Internal.unpackFloat#)+ | [i] <- bitVectorLiterals' args+ -> let resTy = getResultTy tcm ty tys+ val = unpack (toBV i :: BitVector 32)+ in reduce (mkFloatCLit tcm val resTy)++ $(namePat 'Clash.Class.BitPack.Internal.unpackDouble#)+ | [i] <- bitVectorLiterals' args+ -> let resTy = getResultTy tcm ty tys+ val = unpack (toBV i :: BitVector 64)+ in reduce (mkDoubleCLit tcm val resTy)++ $(namePat 'Clash.Sized.Internal.BitVector.xToBV)+ | isSubj+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -- The second argument to `xToBV` is always going to be suspended.+ -- See Note [Lazy primitives]+ , [ _, (Suspend arg) ] <- args+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach1@Machine{mStack=[],mTerm=argWHNF} <-+ whnf eval tcm True (setTerm arg (stackClear mach))+ , let undefBitVector =+ Just $ mach1+ { mStack = mStack mach+ , mTerm = mkBitVectorLit ty nTy kn (bit (fromInteger kn)-1) 0+ }+ -> case isX argWHNF of+ Left _ -> undefBitVector+ _ -> case collectArgs argWHNF of+ (Prim p,_) | primName p `elem` undefinedXPrims -> undefBitVector+ _ -> Just $ mach1+ { mStack = mStack mach+ , mTerm = argWHNF+ }++ -- expIndex#+ -- :: KnownNat m+ -- => Index m+ -- -> SNat n+ -- -> Index (n^m)+ $(namePat 'Clash.Class.Exp.expIndex#)+ | [b] <- indexLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkIndexLit ty (LitTy (NumTy (km^e))) (km^e) (b^e))++ -- expSigned#+ -- :: KnownNat m+ -- => Signed m+ -- -> SNat n+ -- -> Signed (n*m)+ $(namePat 'Clash.Class.Exp.expSigned#)+ | [b] <- signedLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkSignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))++ -- expUnsigned#+ -- :: KnownNat m+ -- => Unsigned m+ -- -> SNat n+ -- -> Unsigned m+ $(namePat 'Clash.Class.Exp.expUnsigned#)+ | [b] <- unsignedLiterals' args+ , [(_mTy, km), (_, e)] <- extractKnownNats tcm tys+ -> reduce (mkUnsignedLit ty (LitTy (NumTy (km*e))) (km*e) (b^e))++ $(namePat 'Clash.Promoted.Nat.powSNat)+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ -> let c = case a of+ 2 -> 1 `shiftL` (fromInteger b)+ _ -> a ^ b+ (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = UniqMap.lookup snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c))+ , Left (Literal (NaturalLiteral c))]++ $(namePat 'Clash.Promoted.Nat.flogBaseSNat)+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- flogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = UniqMap.lookup snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]++ $(namePat 'Clash.Promoted.Nat.clogBaseSNat)+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- clogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = UniqMap.lookup snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]+ | otherwise+ -> error ("clogBaseSNat: args = " <> show args <> ", tys = " <> show tys)++ $(namePat 'Clash.Promoted.Nat.logBaseSNat)+ | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+ , Just c <- flogBase a b+ , let c' = toInteger c+ -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+ (Just snatTc) = UniqMap.lookup snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduce $+ mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+ , Left (Literal (NaturalLiteral c'))]++------------+-- BitVector+------------+-- Constructor+ $(namePat 'Clash.Sized.Internal.BitVector.BV)+ | [Right _] <- map (runExcept . tyNatSize tcm) tys+ , Just (m,i) <- integerLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo m i)++ $(namePat 'Clash.Sized.Internal.BitVector.Bit)+ | Just (m,i) <- integerLiterals args+ -> reduce (mkBitLit ty m i)++-- Initialization+ $(namePat 'Clash.Sized.Internal.BitVector.size#)+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])+ $(namePat 'Clash.Sized.Internal.BitVector.maxIndex#)+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (kn-1)))])++-- Construction+ $(namePat 'Clash.Sized.Internal.BitVector.high)+ -> reduce (mkBitLit ty 0 1)+ $(namePat 'Clash.Sized.Internal.BitVector.low)+ -> reduce (mkBitLit ty 0 0)++ $(namePat 'Clash.Sized.Internal.BitVector.undefined#)+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ mask = bit (fromInteger kn) - 1+ in reduce (mkBitVectorLit' resTyInfo mask 0)++-- Eq+ $(namePat 'Clash.Sized.Internal.BitVector.eq##) | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ $(namePat 'Clash.Sized.Internal.BitVector.neq##) | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ $(namePat 'Clash.Sized.Internal.BitVector.lt##) | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ $(namePat 'Clash.Sized.Internal.BitVector.ge##) | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ $(namePat 'Clash.Sized.Internal.BitVector.gt##) | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ $(namePat 'Clash.Sized.Internal.BitVector.le##) | [(0,i),(0,j)] <- bitLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Enum+ $(namePat 'Clash.Sized.Internal.BitVector.toEnum##)+ | [i] <- intCLiterals' args+ -> let Bit msk val = BitVector.toEnum## (fromInteger i)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))++-- Bits+ $(namePat 'Clash.Sized.Internal.BitVector.and##)+ | [i,j] <- bitLiterals args+ -> let Bit msk val = BitVector.and## (toBit i) (toBit j)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))+ $(namePat 'Clash.Sized.Internal.BitVector.or##)+ | [i,j] <- bitLiterals args+ -> let Bit msk val = BitVector.or## (toBit i) (toBit j)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))+ $(namePat 'Clash.Sized.Internal.BitVector.xor##)+ | [i,j] <- bitLiterals args+ -> let Bit msk val = BitVector.xor## (toBit i) (toBit j)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))++ $(namePat 'Clash.Sized.Internal.BitVector.complement##)+ | [i] <- bitLiterals args+ -> let Bit msk val = BitVector.complement## (toBit i)+ in reduce (mkBitLit ty (toInteger msk) (toInteger val))++-- Pack+ $(namePat 'Clash.Sized.Internal.BitVector.pack#)+ | [(msk,i)] <- bitLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo msk i)++ $(namePat 'Clash.Sized.Internal.BitVector.unpack#)+ | [(msk,i)] <- bitVectorLiterals' args+ -> reduce (mkBitLit ty msk i)++-- Concatenation+ $(namePat '(Clash.Sized.Internal.BitVector.++#)) -- :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)+ | Just (_,m) <- extractKnownNat tcm tys+ , [(mski,i),(mskj,j)] <- bitVectorLiterals' args+ -> let val = i `shiftL` fromInteger m .|. j+ msk = mski `shiftL` fromInteger m .|. mskj+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo msk val)++-- Reduction+ $(namePat 'Clash.Sized.Internal.BitVector.reduceAnd#) -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceAnd# u)+ $(namePat 'Clash.Sized.Internal.BitVector.reduceOr#) -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceOr# u)+ $(namePat 'Clash.Sized.Internal.BitVector.reduceXor#) -- :: KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ val = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy 0 val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (BitVector.reduceXor# u)+++-- Indexing+ $(namePat 'Clash.Sized.Internal.BitVector.index#) -- :: KnownNat n => BitVector n -> Int -> Bit+ | Just (_,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let resTy = getResultTy tcm ty tys+ (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitLit resTy msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = (toInteger m, toInteger v)+ where Bit m v = (BitVector.index# u i)+ $(namePat 'Clash.Sized.Internal.BitVector.replaceBit#) -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n+ | Just (_, n) <- extractKnownNat tcm tys+ , [ _+ , PrimVal bvP _ [_, Lit (NaturalLiteral mskBv), Lit (IntegerLiteral bv)]+ , valArgs -> Just [Literal (IntLiteral i)]+ , PrimVal bP _ [Lit (WordLiteral mskB), Lit (IntegerLiteral b)]+ ] <- args+ , primName bvP == showt 'Clash.Sized.Internal.BitVector.fromInteger#+ , primName bP == showt 'Clash.Sized.Internal.BitVector.fromInteger##+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ (mskVal,val) = reifyNat n (op (BV (fromInteger mskBv) (fromInteger bv))+ (fromInteger i)+ (Bit (fromInteger mskB) (fromInteger b)))+ in reduce (mkBitVectorLit' resTyInfo mskVal val)+ where+ op :: KnownNat n => BitVector n -> Int -> Bit -> Proxy n -> (Integer,Integer)+ -- op bv i b _ = (BitVector.unsafeMask res, BitVector.unsafeToInteger res)+ op bv i b _ = splitBV (BitVector.replaceBit# bv i b)+ $(namePat 'Clash.Sized.Internal.BitVector.setSlice#)+ -- :: SNat (m+1+i) -> BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) -> BitVector (m + 1 + i)+ | mTy : iTy : nTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ , Right iN <- runExcept (tyNatSize tcm iTy)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , [i,j] <- bitVectorLiterals' args+ -> let BV msk val = BitVector.setSlice# (unsafeSNat (m+1+iN)) (toBV i) (unsafeSNat m) (unsafeSNat n) (toBV j)+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))+ $(namePat 'Clash.Sized.Internal.BitVector.slice#)+ -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)+ | mTy : _ : nTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , [i] <- bitVectorLiterals' args+ -> let BV msk val = BitVector.slice# (toBV i) (unsafeSNat m) (unsafeSNat n)+ resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))+ $(namePat 'Clash.Sized.Internal.BitVector.split#) -- :: forall n m. KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n)+ | nTy : mTy : _ <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ , [(mski,i)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty'+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ bvTy : _ = tyArgs+ valM = i `shiftR` fromInteger n+ mskM = mski `shiftR` fromInteger n+ valN = i .&. mask+ mskN = mski .&. mask+ mask = bit (fromInteger n) - 1+ in reduce $+ mkApps (Data tupDc) (map Right tyArgs +++ [ Left (mkBitVectorLit bvTy mTy m mskM valM)+ , Left (mkBitVectorLit bvTy nTy n mskN valN)])++ $(namePat 'Clash.Sized.Internal.BitVector.msb#) -- :: forall n. KnownNat n => BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ , Just (_, kn) <- extractKnownNat tcm tys+ -> let resTy = getResultTy tcm ty tys+ (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitLit resTy (toInteger msk) (toInteger val))+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Word,Word)+ op u _ = (unsafeMask# res, BitVector.unsafeToInteger# res)+ where+ res = BitVector.msb# u+ $(namePat 'Clash.Sized.Internal.BitVector.lsb#) -- :: BitVector n -> Bit+ | [i] <- bitVectorLiterals' args+ -> let resTy = getResultTy tcm ty tys+ Bit msk val = BitVector.lsb# (toBV i)+ in reduce (mkBitLit resTy (toInteger msk) (toInteger val))+++-- Eq+ -- eq#, neq# :: KnownNat n => BitVector n -> BitVector n -> Bool+ $(namePat 'Clash.Sized.Internal.BitVector.eq#)+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.eq# ty tcm args)+ -> reduce val++ $(namePat 'Clash.Sized.Internal.BitVector.neq#)+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.neq# ty tcm args)+ -> reduce val++-- Ord+ -- lt#,ge#,gt#,le# :: KnownNat n => BitVector n -> BitVector n -> Bool+ $(namePat 'Clash.Sized.Internal.BitVector.lt#)+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.lt# ty tcm args)+ -> reduce val+ $(namePat 'Clash.Sized.Internal.BitVector.ge#)+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.ge# ty tcm args)+ -> reduce val+ $(namePat 'Clash.Sized.Internal.BitVector.gt#)+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty False)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.gt# ty tcm args)+ -> reduce val+ $(namePat 'Clash.Sized.Internal.BitVector.le#)+ | nTy : _ <- tys+ , Right 0 <- runExcept (tyNatSize tcm nTy)+ -> reduce (boolToBoolLiteral tcm ty True)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2Bool BitVector.le# ty tcm args)+ -> reduce val++-- Enum++ $(namePat 'Clash.Sized.Internal.BitVector.toEnum#)+ | let resTyInfo@(_,_,kn) = extractTySizeInfo tcm ty tys+ , Just val <- reifyNat kn (liftInteger2BitVector (BitVector.toEnum# . fromInteger) resTyInfo args)+ -> reduce val++ $(namePat 'Clash.Sized.Internal.BitVector.fromEnum#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , let resTy = getResultTy tcm ty tys+ , Just val <- reifyNat kn (liftBitVector2CInt tcm resTy (toInteger . BitVector.fromEnum#) args)+ -> reduce val++-- Bounded+ $(namePat 'Clash.Sized.Internal.BitVector.minBound#)+ | Just (nTy,len) <- extractKnownNat tcm tys+ -> reduce (mkBitVectorLit ty nTy len 0 0)+ $(namePat 'Clash.Sized.Internal.BitVector.maxBound#)+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ mb) - 1+ in reduce (mkBitVectorLit ty litTy mb 0 maxB)++-- Num+ $(namePat '(Clash.Sized.Internal.BitVector.+#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.+#) ty tcm tys args)+ -> reduce val+ $(namePat '(Clash.Sized.Internal.BitVector.-#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.-#) ty tcm tys args)+ -> reduce val+ $(namePat '(Clash.Sized.Internal.BitVector.*#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.*#) ty tcm tys args)+ -> reduce val+ $(namePat 'Clash.Sized.Internal.BitVector.negate#)+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)+ op u _ = splitBV (BitVector.negate# u)++-- ExtendingNum+ $(namePat 'Clash.Sized.Internal.BitVector.plus#) -- :: (KnownNat n, KnownNat m) => BitVector m -> BitVector n -> BitVector (Max m n + 1)+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i+j))++ $(namePat 'Clash.Sized.Internal.BitVector.minus#)+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ val = reifyNat resSizeInt (runSizedF (BitVector.-#) i j)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 val)++ $(namePat 'Clash.Sized.Internal.BitVector.times#)+ | [(0,i),(0,j)] <- bitVectorLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkBitVectorLit resTy resSizeTy resSizeInt 0 (i*j))++-- Integral+ $(namePat 'Clash.Sized.Internal.BitVector.quot#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ $(namePat 'Clash.Sized.Internal.BitVector.rem#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ $(namePat 'Clash.Sized.Internal.BitVector.toInteger#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (toBV i))+ in reduce (integerToIntegerLiteral val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = BitVector.toInteger# u++-- Bits+ $(namePat 'Clash.Sized.Internal.BitVector.and#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.and#) ty tcm tys args)+ -> reduce val+ $(namePat 'Clash.Sized.Internal.BitVector.or#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.or#) ty tcm tys args)+ -> reduce val+ $(namePat 'Clash.Sized.Internal.BitVector.xor#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftBitVector2 (BitVector.xor#) ty tcm tys args)+ -> reduce val++ $(namePat 'Clash.Sized.Internal.BitVector.complement#)+ | [i] <- bitVectorLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let (msk,val) = reifyNat kn (op (toBV i))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> (Integer,Integer)+ op u _ = splitBV $ BitVector.complement# u++ $(namePat 'Clash.Sized.Internal.BitVector.shiftL#)+ | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.shiftL# u i)+ $(namePat 'Clash.Sized.Internal.BitVector.shiftR#)+ | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.shiftR# u i)+ $(namePat 'Clash.Sized.Internal.BitVector.rotateL#)+ | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.rotateL# u i)+ $(namePat 'Clash.Sized.Internal.BitVector.rotateR#)+ | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+ -> let (msk,val) = reifyNat kn (op (toBV i) (fromInteger j))+ in reduce (mkBitVectorLit ty nTy kn msk val)+ where+ op :: KnownNat n => BitVector n -> Int -> Proxy n -> (Integer,Integer)+ op u i _ = splitBV (BitVector.rotateR# u i)++-- truncateB+ $(namePat 'Clash.Sized.Internal.BitVector.truncateB#) -- forall a b . KnownNat a => BitVector (a + b) -> BitVector a+ | aTy : _ <- tys+ , Right ka <- runExcept (tyNatSize tcm aTy)+ , [(mski,i)] <- bitVectorLiterals' args+ -> let bitsKeep = (bit (fromInteger ka)) - 1+ val = i .&. bitsKeep+ msk = mski .&. bitsKeep+ in reduce (mkBitVectorLit ty aTy ka msk val)++--------+-- Index+--------+-- BitPack+ $(namePat 'Clash.Sized.Internal.Index.pack#)+ | nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , [i] <- indexLiterals' args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo 0 i)+ $(namePat 'Clash.Sized.Internal.Index.unpack#)+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [(0,i)] <- bitVectorLiterals' args+ -> reduce (mkIndexLit ty nTy kn i)++-- Eq+ $(namePat 'Clash.Sized.Internal.Index.eq#) | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ $(namePat 'Clash.Sized.Internal.Index.neq#) | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ $(namePat 'Clash.Sized.Internal.Index.lt#)+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ $(namePat 'Clash.Sized.Internal.Index.ge#)+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ $(namePat 'Clash.Sized.Internal.Index.gt#)+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ $(namePat 'Clash.Sized.Internal.Index.le#)+ | Just (i,j) <- indexLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Enum+ $(namePat 'Clash.Sized.Internal.Index.toEnum#)+ | [i] <- intCLiterals' args+ , Just (nTy, mb) <- extractKnownNat tcm tys+ -> reduce (mkIndexLit ty nTy mb i)++ $(namePat 'Clash.Sized.Internal.Index.fromEnum#)+ | [i] <- indexLiterals' args+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkIntCLit tcm i resTy)++-- Bounded+ $(namePat 'Clash.Sized.Internal.Index.maxBound#)+ | Just (nTy,mb) <- extractKnownNat tcm tys+ -> reduce (mkIndexLit ty nTy mb (mb - 1))++-- Num+ $(namePat '(Clash.Sized.Internal.Index.+#))+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i + j))+ $(namePat '(Clash.Sized.Internal.Index.-#))+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i - j))+ $(namePat '(Clash.Sized.Internal.Index.*#))+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [i,j] <- indexLiterals' args+ -> reduce (mkIndexLit ty nTy kn (i * j))++-- ExtendingNum+ $(namePat 'Clash.Sized.Internal.Index.plus#)+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i + j))+ $(namePat 'Clash.Sized.Internal.Index.minus#)+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i - j))+ $(namePat 'Clash.Sized.Internal.Index.times#)+ | mTy : nTy : _ <- tys+ , Right _ <- runExcept (tyNatSize tcm mTy)+ , Right _ <- runExcept (tyNatSize tcm nTy)+ , Just (i,j) <- indexLiterals args+ -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkIndexLit' resTyInfo (i * j))++-- Integral+ $(namePat 'Clash.Sized.Internal.Index.quot#)+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , Just (i,j) <- indexLiterals args+ -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `quot` j))+ $(namePat 'Clash.Sized.Internal.Index.rem#)+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , Just (i,j) <- indexLiterals args+ -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `rem` j))+ $(namePat 'Clash.Sized.Internal.Index.toInteger#)+ | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+ , primName p == showt 'Clash.Sized.Internal.Index.fromInteger#+ -> reduce (integerToIntegerLiteral i)++-- Resize+ $(namePat 'Clash.Sized.Internal.Index.resize#)+ | Just (mTy,m) <- extractKnownNat tcm tys+ , [i] <- indexLiterals' args+ -> reduce (mkIndexLit ty mTy m i)++---------+-- Signed+---------+ $(namePat 'Clash.Sized.Internal.Signed.size#)+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])++-- BitPack+ $(namePat 'Clash.Sized.Internal.Signed.pack#)+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkBitVectorLit ty nTy kn 0 val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.pack# s)+ $(namePat 'Clash.Sized.Internal.Signed.unpack#)+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [(0,i)] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op s _ = toInteger (Signed.unpack# s)++-- Eq+ $(namePat 'Clash.Sized.Internal.Signed.eq#) | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ $(namePat 'Clash.Sized.Internal.Signed.neq#) | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ $(namePat 'Clash.Sized.Internal.Signed.lt#) | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ $(namePat 'Clash.Sized.Internal.Signed.ge#) | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ $(namePat 'Clash.Sized.Internal.Signed.gt#) | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ $(namePat 'Clash.Sized.Internal.Signed.le#) | Just (i,j) <- signedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Enum+ $(namePat 'Clash.Sized.Internal.Signed.toEnum#)+ | [i] <- intCLiterals' args+ , Just (litTy, mb) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty litTy mb i)++ $(namePat 'Clash.Sized.Internal.Signed.fromEnum#)+ | [i] <- signedLiterals' args+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkIntCLit tcm i resTy)++-- Bounded+ $(namePat 'Clash.Sized.Internal.Signed.minBound#)+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let minB = negate (2 ^ (mb - 1))+ in reduce (mkSignedLit ty litTy mb minB)+ $(namePat 'Clash.Sized.Internal.Signed.maxBound#)+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ (mb - 1)) - 1+ in reduce (mkSignedLit ty litTy mb maxB)++-- Num+ $(namePat '(Clash.Sized.Internal.Signed.+#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.+#) ty tcm tys args)+ -> reduce (val)+ $(namePat '(Clash.Sized.Internal.Signed.-#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.-#) ty tcm tys args)+ -> reduce (val)+ $(namePat '(Clash.Sized.Internal.Signed.*#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.*#) ty tcm tys args)+ -> reduce (val)+ $(namePat 'Clash.Sized.Internal.Signed.negate#)+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.negate# s)+ $(namePat 'Clash.Sized.Internal.Signed.abs#)+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op s _ = toInteger (Signed.abs# s)++-- ExtendingNum+ $(namePat 'Clash.Sized.Internal.Signed.plus#)+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i+j))++ $(namePat 'Clash.Sized.Internal.Signed.minus#)+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i-j))++ $(namePat 'Clash.Sized.Internal.Signed.times#)+ | Just (i,j) <- signedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkSignedLit resTy resSizeTy resSizeInt (i*j))++-- Integral+ $(namePat 'Clash.Sized.Internal.Signed.quot#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ $(namePat 'Clash.Sized.Internal.Signed.rem#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ $(namePat 'Clash.Sized.Internal.Signed.div#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.div#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ $(namePat 'Clash.Sized.Internal.Signed.mod#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftSigned2 (Signed.mod#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ $(namePat 'Clash.Sized.Internal.Signed.toInteger#)+ | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+ , primName p == showt 'Clash.Sized.Internal.Signed.fromInteger#+ -> reduce (integerToIntegerLiteral i)++-- Bits+ $(namePat 'Clash.Sized.Internal.Signed.and#)+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i .&. j))+ $(namePat 'Clash.Sized.Internal.Signed.or#)+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i .|. j))+ $(namePat 'Clash.Sized.Internal.Signed.xor#)+ | [i,j] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkSignedLit ty nTy kn (i `xor` j))++ $(namePat 'Clash.Sized.Internal.Signed.complement#)+ | [i] <- signedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Proxy n -> Integer+ op u _ = toInteger (Signed.complement# u)++ $(namePat 'Clash.Sized.Internal.Signed.shiftL#)+ | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.shiftL# u i)+ $(namePat 'Clash.Sized.Internal.Signed.shiftR#)+ | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.shiftR# u i)+ $(namePat 'Clash.Sized.Internal.Signed.rotateL#)+ | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.rotateL# u i)+ $(namePat 'Clash.Sized.Internal.Signed.rotateR#)+ | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkSignedLit ty nTy kn val)+ where+ op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Signed.rotateR# u i)++-- Resize+ $(namePat 'Clash.Sized.Internal.Signed.resize#) -- forall m n. (KnownNat n, KnownNat m) => Signed n -> Signed m+ | mTy : nTy : _ <- tys+ , Right mInt <- runExcept (tyNatSize tcm mTy)+ , Right nInt <- runExcept (tyNatSize tcm nTy)+ , [i] <- signedLiterals' args+ -> let val | nInt <= mInt = extended+ | otherwise = truncated+ extended = i+ mask = 1 `shiftL` fromInteger (mInt - 1)+ i' = i `mod` mask+ truncated = if testBit i (fromInteger nInt - 1)+ then (i' - mask)+ else i'+ in reduce (mkSignedLit ty mTy mInt val)+ $(namePat 'Clash.Sized.Internal.Signed.truncateB#) -- KnownNat m => Signed (m + n) -> Signed m+ | Just (mTy, km) <- extractKnownNat tcm tys+ , [i] <- signedLiterals' args+ -> let bitsKeep = (bit (fromInteger km)) - 1+ val = i .&. bitsKeep+ in reduce (mkSignedLit ty mTy km val)++-- SaturatingNum+-- No need to manually evaluate Clash.Sized.Internal.Signed.minBoundSym#+-- It is just implemented in terms of other primitives.+++-----------+-- Unsigned+-----------+ $(namePat 'Clash.Sized.Internal.Unsigned.size#)+ | Just (_, kn) <- extractKnownNat tcm tys+ -> let (_,ty') = splitFunForallTy ty+ (TyConApp intTcNm _) = tyView ty'+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])++-- BitPack+ $(namePat 'Clash.Sized.Internal.Unsigned.pack#)+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- unsignedLiterals' args+ -> reduce (mkBitVectorLit ty nTy kn 0 i)+ $(namePat 'Clash.Sized.Internal.Unsigned.unpack#)+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- bitVectorLiterals' args+ -> let val = reifyNat kn (op (toBV i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => BitVector n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.unpack# u)++-- Eq+ $(namePat 'Clash.Sized.Internal.Unsigned.eq#) | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i == j))+ $(namePat 'Clash.Sized.Internal.Unsigned.neq#) | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+ $(namePat 'Clash.Sized.Internal.Unsigned.lt#) | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i < j))+ $(namePat 'Clash.Sized.Internal.Unsigned.ge#) | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i >= j))+ $(namePat 'Clash.Sized.Internal.Unsigned.gt#) | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i > j))+ $(namePat 'Clash.Sized.Internal.Unsigned.le#) | Just (i,j) <- unsignedLiterals args+ -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Enum+ $(namePat 'Clash.Sized.Internal.Unsigned.toEnum#)+ | [i] <- intCLiterals' args+ , Just (litTy, mb) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty litTy mb i)++ $(namePat 'Clash.Sized.Internal.Unsigned.fromEnum#)+ | [i] <- unsignedLiterals' args+ -> let resTy = getResultTy tcm ty tys+ in reduce (mkIntCLit tcm i resTy)++-- Bounded+ $(namePat 'Clash.Sized.Internal.Unsigned.minBound#)+ | Just (nTy,len) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy len 0)+ $(namePat 'Clash.Sized.Internal.Unsigned.maxBound#)+ | Just (litTy,mb) <- extractKnownNat tcm tys+ -> let maxB = (2 ^ mb) - 1+ in reduce (mkUnsignedLit ty litTy mb maxB)++-- Num+ $(namePat '(Clash.Sized.Internal.Unsigned.+#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.+#) ty tcm tys args)+ -> reduce val+ $(namePat '(Clash.Sized.Internal.Unsigned.-#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.-#) ty tcm tys args)+ -> reduce val+ $(namePat '(Clash.Sized.Internal.Unsigned.*#))+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.*#) ty tcm tys args)+ -> reduce val+ $(namePat 'Clash.Sized.Internal.Unsigned.negate#)+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i] <- unsignedLiterals' args+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.negate# u)++-- ExtendingNum+ $(namePat 'Clash.Sized.Internal.Unsigned.plus#) -- :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)+ | Just (i,j) <- unsignedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i+j))++ $(namePat 'Clash.Sized.Internal.Unsigned.minus#)+ | [i,j] <- unsignedLiterals' args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ val = reifyNat resSizeInt (runSizedF (Unsigned.-#) i j)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt val)++ $(namePat 'Clash.Sized.Internal.Unsigned.times#)+ | Just (i,j) <- unsignedLiterals args+ -> let ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ (TyConApp _ [resSizeTy]) = tyView resTy+ Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+ in reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i*j))++-- Integral+ $(namePat 'Clash.Sized.Internal.Unsigned.quot#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.quot#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ $(namePat 'Clash.Sized.Internal.Unsigned.rem#)+ | Just (_, kn) <- extractKnownNat tcm tys+ , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.rem#) ty tcm tys args)+ -> reduce $ catchDivByZero val+ $(namePat 'Clash.Sized.Internal.Unsigned.toInteger#)+ | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+ , primName p == showt 'Clash.Sized.Internal.Unsigned.fromInteger#+ -> reduce (integerToIntegerLiteral i)++-- Bits+ $(namePat 'Clash.Sized.Internal.Unsigned.and#)+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i .&. j))+ $(namePat 'Clash.Sized.Internal.Unsigned.or#)+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i .|. j))+ $(namePat 'Clash.Sized.Internal.Unsigned.xor#)+ | Just (i,j) <- unsignedLiterals args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> reduce (mkUnsignedLit ty nTy kn (i `xor` j))++ $(namePat 'Clash.Sized.Internal.Unsigned.complement#)+ | [i] <- unsignedLiterals' args+ , Just (nTy, kn) <- extractKnownNat tcm tys+ -> let val = reifyNat kn (op (fromInteger i))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Proxy n -> Integer+ op u _ = toInteger (Unsigned.complement# u)++ $(namePat 'Clash.Sized.Internal.Unsigned.shiftL#) -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+ | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.shiftL# u i)+ $(namePat 'Clash.Sized.Internal.Unsigned.shiftR#) -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+ | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.shiftR# u i)+ $(namePat 'Clash.Sized.Internal.Unsigned.rotateL#) -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+ | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.rotateL# u i)+ $(namePat 'Clash.Sized.Internal.Unsigned.rotateR#) -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+ | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+ -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+ in reduce (mkUnsignedLit ty nTy kn val)+ where+ op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+ op u i _ = toInteger (Unsigned.rotateR# u i)++-- Resize+ $(namePat 'Clash.Sized.Internal.Unsigned.resize#) -- forall n m . KnownNat m => Unsigned n -> Unsigned m+ | _ : mTy : _ <- tys+ , Right km <- runExcept (tyNatSize tcm mTy)+ , [i] <- unsignedLiterals' args+ -> let bitsKeep = (bit (fromInteger km)) - 1+ val = i .&. bitsKeep+ in reduce (mkUnsignedLit ty mTy km val)++-- Conversions+ $(namePat 'Clash.Sized.Internal.Unsigned.unsignedToWord)+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsignedToWord (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = UniqMap.lookup wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ $(namePat 'Clash.Sized.Internal.Unsigned.unsigned8toWord8)+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned8toWord8 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = UniqMap.lookup wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ $(namePat 'Clash.Sized.Internal.Unsigned.unsigned16toWord16)+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned16toWord16 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = UniqMap.lookup wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ $(namePat 'Clash.Sized.Internal.Unsigned.unsigned32toWord32)+ | isSubj+ , [a] <- unsignedLiterals' args+ -> let b = Unsigned.unsigned32toWord32 (U (fromInteger a))+ (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+ (Just wordTc) = UniqMap.lookup wordTcNm tcm+ [wordDc] = tyConDataCons wordTc+ in reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral (toInteger b)))])++ $(namePat 'Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL)+ | isSubj+ , f : a : _ <- args+ -> reduceWHNF (mkApps (valToTerm f) [Left (valToTerm a)])++--------+-- RTree+--------+ $(namePat 'Clash.Sized.RTree.textract)+ | isSubj+ , [DC _ tArgs] <- args+ -> reduceWHNF (Either.lefts tArgs !! 1)++ $(namePat 'Clash.Sized.RTree.tsplit)+ | isSubj+ , dTy : aTy : _ <- tys+ , [DC _ tArgs] <- args+ , (tyArgs,tyView -> TyConApp tupTcNm _) <- splitFunForallTy ty+ , TyConApp treeTcNm _ <- tyView (Either.rights tyArgs !! 0)+ -> let (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ in reduce $+ mkApps (Data tupDc)+ [Right (mkTyConApp treeTcNm [dTy,aTy])+ ,Right (mkTyConApp treeTcNm [dTy,aTy])+ ,Left (Either.lefts tArgs !! 1)+ ,Left (Either.lefts tArgs !! 2)+ ]++ $(namePat 'Clash.Sized.RTree.tdfold)+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : g : ts : _ <- args+ , DC _ tArgs <- ts+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts tArgs !! 1)])+ _ -> let k'ty = LitTy (NumTy (k'-1))+ (tyArgs,_) = splitFunForallTy ty+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = UniqMap.lookup snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ in reduceWHNF $+ mkApps (valToTerm g)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Either.lefts tArgs !! 1)+ ])+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Either.lefts tArgs !! 2)+ ])+ ]++ $(namePat 'Clash.Sized.RTree.treplicate)+ | isSubj+ , let ty' = piResultTys tcm ty tys+ , (_,tyView -> TyConApp treeTcNm [lenTy,argTy]) <- splitFunForallTy ty'+ , Right len <- runExcept (tyNatSize tcm lenTy)+ -> let (Just treeTc) = UniqMap.lookup treeTcNm tcm+ [lrCon,brCon] = tyConDataCons treeTc+ in reduce (mkRTree lrCon brCon argTy len (replicate (2^len) (valToTerm (last args))))++---------+-- Vector+---------+ $(namePat 'Clash.Sized.Vector.length) -- :: KnownNat n => Vec n a -> Int+ | isSubj+ , [nTy, _] <- tys+ , Right n <-runExcept (tyNatSize tcm nTy)+ -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger n)))])++ -- XXX: Not a thing anymore?+ "Clash.Sized.Vector.maxIndex"+ | isSubj+ , [nTy, _] <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty+ (Just intTc) = UniqMap.lookup intTcNm tcm+ [intCon] = tyConDataCons intTc+ in reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger (n - 1))))])++-- Indexing+ -- XXX: Not exported+ "Clash.Sized.Vector.index_int" -- :: KnownNat n => Vec n a -> Int+ | nTy : aTy : _ <- tys+ , _ : xs : i : _ <- args+ , DC intDc [Left (Literal (IntLiteral i'))] <- i+ -> if i' < 0+ then Nothing+ else case xs of+ DC _ vArgs -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> Nothing+ Right n' ->+ if i' == 0+ then reduceWHNF (Either.lefts vArgs !! 1)+ else reduceWHNF $+ mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (Data intDc)+ [Left (Literal (IntLiteral (i'-1)))])+ ]+ _ -> Nothing+ _ -> Nothing+ $(namePat 'Clash.Sized.Vector.head) -- :: Vec (n+1) a -> a+ | isSubj+ , [DC _ vArgs] <- args+ -> reduceWHNF (Either.lefts vArgs !! 1)+ $(namePat 'Clash.Sized.Vector.last) -- :: Vec (n+1) a -> a+ | isSubj+ , [DC _ vArgs] <- args+ , (Right _ : Right aTy : Right nTy : _) <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> if n == 0+ then reduceWHNF (Either.lefts vArgs !! 1)+ else reduceWHNF+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)+ ])+-- - Sub-vectors+ $(namePat 'Clash.Sized.Vector.tail) -- :: Vec (n+1) a -> Vec n a+ | isSubj+ , [DC _ vArgs] <- args+ -> reduceWHNF (Either.lefts vArgs !! 2)+ $(namePat 'Clash.Sized.Vector.init) -- :: Vec (n+1) a -> Vec n a+ | isSubj+ , [DC consCon vArgs] <- args+ , (Right _ : Right aTy : Right nTy : _) <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> if n == 0+ then reduceWHNF (Either.lefts vArgs !! 2)+ else reduce $+ mkVecCons consCon aTy n+ (Either.lefts vArgs !! 1)+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)])+ $(namePat 'Clash.Sized.Vector.select) -- :: (CmpNat (i+s) (s*n) ~ GT) => SNat f -> SNat s -> SNat n -> Vec (f + i) a -> Vec n a+ | isSubj+ , iTy : sTy : nTy : fTy : aTy : _ <- tys+ , eq : f : s : n : xs : _ <- args+ , Right n' <- runExcept (tyNatSize tcm nTy)+ , Right f' <- runExcept (tyNatSize tcm fTy)+ , Right i' <- runExcept (tyNatSize tcm iTy)+ , Right s' <- runExcept (tyNatSize tcm sTy)+ , DC _ vArgs <- xs+ -> case n' of+ 0 -> reduce (mkVecNil nilCon aTy)+ _ -> case f' of+ 0 -> let splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right sTy+ ,Right (LitTy (NumTy (i'-s')))+ ,Right aTy+ ,Left (valToTerm s)+ ,Left (valToTerm xs)+ ]+ fVecTy = mkTyConApp vecTcNm [sTy,aTy]+ iVecTy = mkTyConApp vecTcNm [LitTy (NumTy (i'-s')),aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ fNm = mkUnsafeSystemName "fxs" 0+ iNm = mkUnsafeSystemName "ixs" 1+ fId = mkLocalId fVecTy fNm+ iId = mkLocalId iVecTy iNm+ tupPat = DataPat tupDc [] [fId,iId]+ iAlt = (tupPat, (Var iId))+ in reduce $+ mkVecCons consCon aTy n' (Either.lefts vArgs !! 1) $+ mkApps (Prim pInfo)+ [Right (LitTy (NumTy (i'-s')))+ ,Right sTy+ ,Right (LitTy (NumTy (n'-1)))+ ,Right (LitTy (NumTy 0))+ ,Right aTy+ ,Left (valToTerm eq)+ ,Left (Literal (NaturalLiteral 0))+ ,Left (valToTerm s)+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Case splitAtCall iVecTy [iAlt])+ ]+ _ -> let splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right fTy+ ,Right iTy+ ,Right aTy+ ,Left (valToTerm f)+ ,Left (valToTerm xs)+ ]+ fVecTy = mkTyConApp vecTcNm [fTy,aTy]+ iVecTy = mkTyConApp vecTcNm [iTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ fNm = mkUnsafeSystemName "fxs" 0+ iNm = mkUnsafeSystemName "ixs" 1+ fId = mkLocalId fVecTy fNm+ iId = mkLocalId iVecTy iNm+ tupPat = DataPat tupDc [] [fId,iId]+ iAlt = (tupPat, (Var iId))+ in reduceWHNF $+ mkApps (Prim pInfo)+ [Right iTy+ ,Right sTy+ ,Right nTy+ ,Right (LitTy (NumTy 0))+ ,Right aTy+ ,Left (valToTerm eq)+ ,Left (Literal (NaturalLiteral 0))+ ,Left (valToTerm s)+ ,Left (valToTerm n)+ ,Left (Case splitAtCall iVecTy [iAlt])+ ]+ where+ (tyArgs,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ Just vecTc = UniqMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs !! 1)+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+-- - Splitting+ $(namePat 'Clash.Sized.Vector.splitAt) -- :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)+ | isSubj+ , (DC snatDc (Right mTy:_)):_ <- args+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> let _:nTy:aTy:_ = tys+ -- Get the tuple data-constructor+ ty1 = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs@(tyArg:_)) = splitFunForallTy ty1+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ -- Get the vector data-constructors+ TyConApp vecTcNm _ = tyView tyArg+ Just vecTc = UniqMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ -- Recursive call to @splitAt@+ splitAtRec v =+ mkApps (Prim pInfo)+ [Right (LitTy (NumTy (m-1)))+ ,Right nTy+ ,Right aTy+ ,Left (mkApps (Data snatDc)+ [ Right (LitTy (NumTy (m-1)))+ , Left (Literal (NaturalLiteral (m-1)))])+ ,Left v+ ]+ -- Projection either the first or second field of the recursive+ -- call to @splitAt@+ splitAtSelR v = Case (splitAtRec v)+ m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]+ nVecTy = mkTyConApp vecTcNm [nTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ lNm = mkUnsafeSystemName "l" 0+ rNm = mkUnsafeSystemName "r" 1+ lId = mkLocalId m1VecTy lNm+ rId = mkLocalId nVecTy rNm+ tupPat = DataPat tupDc [] [lId,rId]+ lAlt = (tupPat, (Var lId))+ rAlt = (tupPat, (Var rId))++ in case m of+ -- (Nil,v)+ 0 -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecNil nilCon aTy)+ , Left (valToTerm (last args))+ ]+ -- (x:xs) <- v+ m' | DC _ vArgs <- last args+ -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))+ -> case Either.lefts vArgs of+ (_ : x : xs : _) ->+ reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecCons consCon aTy m' x+ (splitAtSelR xs m1VecTy [lAlt]))+ , Left (splitAtSelR xs nVecTy [rAlt])+ ]+ _ ->+ -- v actually reduces to Nil and not Cons, this only happens+ -- when 'n' would reduce to a negative number; the complement+ -- of 'm'.+ --+ -- See Clash issue: https://github.com/clash-lang/clash-compiler/issues/2831+ let resTy = getResultTy tcm ty tys+ in reduce (TyApp (Prim NP.undefined) resTy)++ -- v doesn't reduce to a data-constructor+ _ -> Nothing++ $(namePat 'Clash.Sized.Vector.unconcat) -- :: KnownNat n => SNamt m -> Vec (n * m) a -> Vec n (Vec m a)+ | isSubj+ , kn : snat : v : _ <- args+ , nTy : mTy : aTy :_ <- tys+ , Lit (NaturalLiteral n) <- kn+ -> let ( Either.rights -> argTys, tyView -> TyConApp vecTcNm _) =+ splitFunForallTy ty+ Just vecTc = UniqMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ TyConApp snatTcNm _ = tyView (argTys !! 1)+ n1mTy = mkTyConApp typeNatMul+ [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)]+ ,mTy]+ splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right mTy+ ,Right n1mTy+ ,Right aTy+ ,Left (valToTerm snat)+ ,Left (valToTerm v)+ ]+ mVecTy = mkTyConApp vecTcNm [mTy,aTy]+ n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ asNm = mkUnsafeSystemName "as" 0+ bsNm = mkUnsafeSystemName "bs" 1+ asId = mkLocalId mVecTy asNm+ bsId = mkLocalId n1mVecTy bsNm+ tupPat = DataPat tupDc [] [asId,bsId]+ asAlt = (tupPat, (Var asId))+ bsAlt = (tupPat, (Var bsId))++ in case n of+ 0 -> reduce (mkVecNil nilCon mVecTy)+ _ -> reduce $+ mkVecCons consCon mVecTy n+ (Case splitAtCall mVecTy [asAlt])+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right mTy+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n-1)))+ ,Left (valToTerm snat)+ ,Left (Case splitAtCall n1mVecTy [bsAlt])])+-- Construction+-- - initialisation+ $(namePat 'Clash.Sized.Vector.replicate) -- :: SNat n -> a -> Vec n a+ | isSubj+ , let ty' = piResultTys tcm ty tys+ , let (_,resTy) = splitFunForallTy ty'+ , (TyConApp vecTcNm [lenTy,argTy]) <- tyView resTy+ , Right len <- runExcept (tyNatSize tcm lenTy)+ -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduce $+ mkVec nilCon consCon argTy len+ (replicate (fromInteger len) (valToTerm (last args)))+-- - Concatenation+ $(namePat '(Clash.Sized.Vector.++)) -- :: Vec n a -> Vec m a -> Vec (n + m) a+ | isSubj+ , (DC dc vArgs):_ <- args+ , Right nTy : Right aTy : _ <- vArgs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (valToTerm (last args))+ n' | (_ : _ : mTy : _) <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> -- x : (xs ++ ys)+ reduce $+ mkVecCons dc aTy (n' + m) (Either.lefts vArgs !! 1)+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Right mTy+ ,Left (Either.lefts vArgs !! 2)+ ,Left (valToTerm (last args))+ ])+ _ -> Nothing+ $(namePat 'Clash.Sized.Vector.concat) -- :: Vec n (Vec m a) -> Vec (n * m) a+ | isSubj+ , (nTy : mTy : aTy : _) <- tys+ , (xs : _) <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ _ | _ : h' : t : _ <- Either.lefts vArgs+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ -> reduceWHNF $+ mkApps (vecAppendPrim vecTcNm)+ [Right mTy+ ,Right aTy+ ,Right $ mkTyConApp typeNatMul+ [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)], mTy]+ ,Left h'+ ,Left $ mkApps (Prim pInfo)+ [ Right (LitTy (NumTy (n-1)))+ , Right mTy+ , Right aTy+ , Left t+ ]+ ]+ _ -> Nothing++-- Modifying vectors+ "Clash.Sized.Vector.replace_int" -- :: KnownNat n => Vec n a -> Int -> a -> Vec n a+ | nTy : aTy : _ <- tys+ , _ : xs : i : a : _ <- args+ , DC intDc [Left (Literal (IntLiteral i'))] <- i+ -> if i' < 0+ then Nothing+ else case xs of+ DC vecTcNm vArgs -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> Nothing+ Right n' ->+ if i' == 0+ then reduce (mkVecCons vecTcNm aTy n' (valToTerm a) (Either.lefts vArgs !! 2))+ else reduce $+ mkVecCons vecTcNm aTy n' (Either.lefts vArgs !! 1)+ (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (Literal (NaturalLiteral (n'-1)))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (Data intDc)+ [Left (Literal (IntLiteral (i'-1)))])+ ,Left (valToTerm a)+ ])+ _ -> Nothing+ _ -> Nothing++-- - specialized permutations+ $(namePat 'Clash.Sized.Vector.reverse) -- :: Vec n a -> Vec n a+ | isSubj+ , nTy : aTy : _ <- tys+ , [DC vecDc vArgs] <- args+ -> case runExcept (tyNatSize tcm nTy) of+ Right 0 -> reduce (mkVecNil vecDc aTy)+ Right n+ | (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , let (Just vecTc) = UniqMap.lookup vecTcNm tcm+ , let [nilCon,consCon] = tyConDataCons vecTc+ -> reduceWHNF $+ mkApps (vecAppendPrim vecTcNm)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Right (LitTy (NumTy 1))+ ,Left (mkApps (Prim pInfo)+ [Right (LitTy (NumTy (n-1)))+ ,Right aTy+ ,Left (Either.lefts vArgs !! 2)+ ])+ ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])+ ]+ _ -> Nothing+ $(namePat 'Clash.Sized.Vector.transpose) -- :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)+ | isSubj+ , nTy : mTy : aTy : _ <- tys+ , kn : xss : _ <- args+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , DC _ vArgs <- xss+ , Right n <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> case m of+ 0 -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduce $+ mkVec nilCon consCon (mkTyConApp vecTcNm [mTy,aTy]) n+ (replicate (fromInteger n) (mkVec nilCon consCon aTy 0 []))+ m' -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ Just (consCoTy : _) = dataConInstArgTys consCon+ [mTy,aTy,LitTy (NumTy (m'-1))]+ in reduceWHNF $+ mkApps (vecZipWithPrim vecTcNm)+ [ Right aTy+ , Right (mkTyConApp vecTcNm [LitTy (NumTy (m'-1)),aTy])+ , Right (mkTyConApp vecTcNm [mTy,aTy])+ , Right nTy+ , Left (mkApps (Data consCon)+ [Right mTy+ ,Right aTy+ ,Right (LitTy (NumTy (m'-1)))+ ,Left (primCo consCoTy)+ ])+ , Left (Either.lefts vArgs !! 1)+ , Left (mkApps (Prim pInfo)+ [ Right nTy+ , Right (LitTy (NumTy (m'-1)))+ , Right aTy+ , Left (valToTerm kn)+ , Left (Either.lefts vArgs !! 2)+ ])+ ]++ $(namePat 'Clash.Sized.Vector.rotateLeftS) -- :: KnownNat n => Vec n a -> SNat d -> Vec n a+ | nTy : aTy : _ : _ <- tys+ , kn : xs : d : _ <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ n' | DC snatDc [_,Left d'] <- d+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf eval tcm isSubj (setTerm d' $ stackClear mach)+ -> case (d2 `mod` n) of+ 0 -> reduce (valToTerm xs)+ d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ (Just vecTc) = UniqMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ in reduceWHNF' mach2 $+ mkApps (Prim pInfo)+ [Right nTy+ ,Right aTy+ ,Right (LitTy (NumTy (d3-1)))+ ,Left (valToTerm kn)+ ,Left (mkApps (vecAppendPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Right (LitTy (NumTy 1))+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])])+ ,Left (mkApps (Data snatDc)+ [Right (LitTy (NumTy (d3-1)))+ ,Left (Literal (NaturalLiteral (d3-1)))])+ ]+ _ -> Nothing++ $(namePat 'Clash.Sized.Vector.rotateRightS) -- :: KnownNat n => Vec n a -> SNat d -> Vec n a+ | isSubj+ , nTy : aTy : _ : _ <- tys+ , kn : xs : d : _ <- args+ , DC dc _ <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc aTy)+ n' | DC snatDc [_,Left d'] <- d+ , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf eval tcm isSubj (setTerm d' $ stackClear mach)+ -> case (d2 `mod` n) of+ 0 -> reduce (valToTerm xs)+ d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+ in reduceWHNF' mach2 $+ mkApps (Prim pInfo)+ [Right nTy+ ,Right aTy+ ,Right (LitTy (NumTy (d3-1)))+ ,Left (valToTerm kn)+ ,Left (mkVecCons dc aTy n+ (mkApps (vecLastPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (valToTerm xs)])+ (mkApps (vecInitPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right aTy+ ,Left (valToTerm xs)]))+ ,Left (mkApps (Data snatDc)+ [Right (LitTy (NumTy (d3-1)))+ ,Left (Literal (NaturalLiteral (d3-1)))])+ ]+ _ -> Nothing+-- Element-wise operations+-- - mapping+ $(namePat 'Clash.Sized.Vector.map) -- :: (a -> b) -> Vec n a -> Vec n b+ | isSubj+ , DC dc vArgs <- args !! 1+ , aTy : bTy : nTy : _ <- tys+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc bTy)+ n' -> reduce $+ mkVecCons dc bTy n'+ (mkApps (valToTerm (args !! 0)) [Left (Either.lefts vArgs !! 1)])+ (mkApps (Prim pInfo)+ [Right aTy+ ,Right bTy+ ,Right (LitTy (NumTy (n' - 1)))+ ,Left (valToTerm (args !! 0))+ ,Left (Either.lefts vArgs !! 2)])+ $(namePat 'Clash.Sized.Vector.imap) -- :: forall n a b . KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b+ | isSubj+ , nTy : aTy : bTy : _ <- tys+ , (tyArgs,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , let (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 1)+ , TyConApp indexTcNm _ <- tyView (Either.rights tyArgs' !! 0)+ , Right n <- runExcept (tyNatSize tcm nTy)+ , let iLit = mkIndexLit (Either.rights tyArgs' !! 0) nTy n 0+ -> reduceWHNF $+ mkApps (Prim (PrimInfo "Clash.Sized.Vector.imap_go" (vecImapGoTy vecTcNm indexTcNm) WorkNever SingleResult NoUnfolding))+ [Right nTy+ ,Right nTy+ ,Right aTy+ ,Right bTy+ ,Left (valToTerm (args !! 1))+ ,Left (valToTerm (args !! 2))+ ,Left iLit+ ]++ "Clash.Sized.Vector.imap_go"+ | isSubj+ , nTy : mTy : aTy : bTy : _ <- tys+ , f : xs : (Suspend nArg) : _ <- args+ , DC dc vArgs <- xs+ , Right n' <- runExcept (tyNatSize tcm nTy)+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> case m of+ 0 -> reduce (mkVecNil dc bTy)+ m'+ | eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ , mach1@Machine{mStack=[],mTerm=n} <-+ whnf eval tcm True (setTerm nArg (stackClear mach))+ -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp indexTcNm _ = tyView (Either.rights tyArgs !! 2)+ iLit = mkIndexLit (Either.rights tyArgs !! 2) nTy n' 1+ in Just $ flip setTerm (mach1 {mStack = mStack mach}) $ mkVecCons dc bTy m'+ (mkApps (valToTerm f) [Left n,Left (Either.lefts vArgs !! 1)])+ (mkApps (Prim pInfo)+ [Right nTy+ ,Right (LitTy (NumTy (m'-1)))+ ,Right aTy+ ,Right bTy+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (Prim (PrimInfo (showt '(Clash.Sized.Internal.Index.+#)) (indexAddTy indexTcNm) WorkVariable SingleResult NoUnfolding))+ [Right nTy+ ,Left (Literal (NaturalLiteral n'))+ ,Left n+ ,Left iLit+ ])+ ])+ | otherwise+ -> Nothing++ -- :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a+ $(namePat 'Clash.Sized.Vector.iterateI)+ | isSubj+ , [nTy, aTy] <- tys+ , [_n, f, a] <- args+ , Right n <- runExcept (tyNatSize tcm nTy)+ ->+ let+ TyConApp vecTcNm _ = tyView (getResultTy tcm ty tys)+ Just vecTc = UniqMap.lookup vecTcNm tcm+ [nilCon, consCon] = tyConDataCons vecTc+ in case n of+ 0 -> reduce (mkVecNil nilCon aTy)+ _ -> reduce $+ mkVecCons consCon aTy n+ (valToTerm a)+ (mkApps+ (Prim pInfo)+ [ Right (LitTy (NumTy (n - 1)))+ , Right aTy+ , Left (valToTerm (Lit (NaturalLiteral (n - 1))))+ , Left (valToTerm f)+ , Left (mkApps (valToTerm f) [Left (valToTerm a)])+ ])++-- - Zipping+ $(namePat 'Clash.Sized.Vector.zipWith) -- :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c+ | isSubj+ , aTy : bTy : cTy : nTy : _ <- tys+ , f : xs : ys : _ <- args+ , DC dc vArgs <- xs+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (mkVecNil dc cTy)+ n' -> reduce $ mkVecCons dc cTy n'+ (mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (vecHeadPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right bTy+ ,Left (valToTerm ys)+ ])+ ])+ (mkApps (Prim pInfo)+ [Right aTy+ ,Right bTy+ ,Right cTy+ ,Right (LitTy (NumTy (n' - 1)))+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ,Left (mkApps (vecTailPrim vecTcNm)+ [Right (LitTy (NumTy (n'-1)))+ ,Right bTy+ ,Left (valToTerm ys)+ ])])++-- Folding+ $(namePat 'Clash.Sized.Vector.foldr) -- :: (a -> b -> b) -> b -> Vec n a -> b+ | isSubj+ , aTy : bTy : nTy : _ <- tys+ , f : z : xs : _ <- args+ , DC _ vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduce (valToTerm z)+ _ -> reduceWHNF $+ mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (Prim pInfo)+ [Right aTy+ ,Right bTy+ ,Right (LitTy (NumTy (n-1)))+ ,Left (valToTerm f)+ ,Left (valToTerm z)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ $(namePat 'Clash.Sized.Vector.fold) -- :: (a -> a -> a) -> Vec (n + 1) a -> a+ | isSubj+ , nTy : aTy : _ <- tys+ , f : vs : _ <- args+ , DC _ vArgs <- vs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> reduceWHNF (Either.lefts vArgs !! 1)+ _ -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 1)+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ n' = n+1+ m = n' `div` 2+ n1 = n' - m+ mTy = LitTy (NumTy m)+ m'ty = LitTy (NumTy (m-1))+ n1mTy = LitTy (NumTy n1)+ n1m'ty = LitTy (NumTy (n1-1))+ splitAtCall =+ mkApps (Prim (PrimInfo "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm) WorkNever SingleResult NoUnfolding))+ [Right mTy+ ,Right n1mTy+ ,Right aTy+ ,Left (Literal (NaturalLiteral m))+ ,Left (valToTerm vs)+ ]+ mVecTy = mkTyConApp vecTcNm [mTy,aTy]+ n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ asNm = mkUnsafeSystemName "as" 0+ bsNm = mkUnsafeSystemName "bs" 1+ asId = mkLocalId mVecTy asNm+ bsId = mkLocalId n1mVecTy bsNm+ tupPat = DataPat tupDc [] [asId,bsId]+ asAlt = (tupPat, (Var asId))+ bsAlt = (tupPat, (Var bsId))+ in reduceWHNF $+ mkApps (valToTerm f)+ [Left (mkApps (Prim pInfo)+ [Right m'ty+ ,Right aTy+ ,Left (valToTerm f)+ ,Left (Case splitAtCall mVecTy [asAlt])+ ])+ ,Left (mkApps (Prim pInfo)+ [Right n1m'ty+ ,Right aTy+ ,Left (valToTerm f)+ ,Left (Case splitAtCall n1mVecTy [bsAlt])+ ])+ ]+++ "Clash.Sized.Vector.fold_split" -- :: Natural -> Vec (m + n) a -> (Vec m a, Vec n a)+ | isSubj+ , mTy : nTy : aTy : _ <- tys+ , Right m <- runExcept (tyNatSize tcm mTy)+ -> let -- Get the tuple data-constructor+ ty1 = piResultTys tcm ty tys+ (_,tyView -> TyConApp tupTcNm tyArgs@(tyArg:_)) = splitFunForallTy ty1+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ -- Get the vector data-constructors+ TyConApp vecTcNm _ = tyView tyArg+ Just vecTc = UniqMap.lookup vecTcNm tcm+ [nilCon,consCon] = tyConDataCons vecTc+ -- Recursive call to @splitAt@+ splitAtRec v =+ mkApps (Prim pInfo)+ [Right (LitTy (NumTy (m-1)))+ ,Right nTy+ ,Right aTy+ ,Left (Literal (NaturalLiteral (m-1)))+ ,Left v+ ]+ -- Projection either the first or second field of the recursive+ -- call to @splitAt@+ splitAtSelR v = Case (splitAtRec v)+ m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]+ nVecTy = mkTyConApp vecTcNm [nTy,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ lNm = mkUnsafeSystemName "l" 0+ rNm = mkUnsafeSystemName "r" 1+ lId = mkLocalId m1VecTy lNm+ rId = mkLocalId nVecTy rNm+ tupPat = DataPat tupDc [] [lId,rId]+ lAlt = (tupPat, (Var lId))+ rAlt = (tupPat, (Var rId))+ in case m of+ -- (Nil,v)+ 0 -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecNil nilCon aTy)+ , Left (valToTerm (last args))+ ]+ -- (x:xs) <- v+ m' | DC _ vArgs <- last args+ -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))+ -> reduce $+ mkApps (Data tupDc) $ (map Right tyArgs) +++ [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)+ (splitAtSelR (Either.lefts vArgs !! 2) m1VecTy [lAlt]))+ , Left (splitAtSelR (Either.lefts vArgs !! 2) nVecTy [rAlt])+ ]+ -- v doesn't reduce to a data-constructor+ _ -> Nothing+-- - Specialised folds+ $(namePat 'Clash.Sized.Vector.dfold)+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : z : xs : _ <- args+ , DC _ vArgs <- xs+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduce (valToTerm z)+ _ -> let (tyArgs,_) = splitFunForallTy ty+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 2)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = UniqMap.lookup snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ k'ty = LitTy (NumTy (k'-1))+ in reduceWHNF $+ mkApps (valToTerm f)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (Either.lefts vArgs !! 1)+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm z)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ $(namePat 'Clash.Sized.Vector.dtfold)+ | isSubj+ , pTy : kTy : aTy : _ <- tys+ , _ : p : f : g : xs : _ <- args+ , DC _ vArgs <- xs+ , Right k' <- runExcept (tyNatSize tcm kTy)+ -> case k' of+ 0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts vArgs !! 1)])+ _ -> let (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 4)+ (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)+ TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+ Just snatTc = UniqMap.lookup snatTcNm tcm+ [snatDc] = tyConDataCons snatTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ k'ty = LitTy (NumTy (k'-1))+ k2ty = LitTy (NumTy (2^(k'-1)))+ splitAtCall =+ mkApps (splitAtPrim snatTcNm vecTcNm)+ [Right k2ty+ ,Right k2ty+ ,Right aTy+ ,Left (mkApps (Data snatDc)+ [Right k2ty+ ,Left (Literal (NaturalLiteral (2^(k'-1))))])+ ,Left (valToTerm xs)+ ]+ xsSVecTy = mkTyConApp vecTcNm [k2ty,aTy]+ -- Guaranteed no capture, so okay to use unsafe name generation+ xsLNm = mkUnsafeSystemName "xsL" 0+ xsRNm = mkUnsafeSystemName "xsR" 1+ xsLId = mkLocalId k2ty xsLNm+ xsRId = mkLocalId k2ty xsRNm+ tupPat = DataPat tupDc [] [xsLId,xsRId]+ asAlt = (tupPat, (Var xsLId))+ bsAlt = (tupPat, (Var xsRId))+ in reduceWHNF $+ mkApps (valToTerm g)+ [Right k'ty+ ,Left (mkApps (Data snatDc)+ [Right k'ty+ ,Left (Literal (NaturalLiteral (k'-1)))])+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Case splitAtCall xsSVecTy [asAlt])])+ ,Left (mkApps (Prim pInfo)+ [Right pTy+ ,Right k'ty+ ,Right aTy+ ,Left (Literal (NaturalLiteral (k'-1)))+ ,Left (valToTerm p)+ ,Left (valToTerm f)+ ,Left (valToTerm g)+ ,Left (Case splitAtCall xsSVecTy [bsAlt])])+ ]+-- Misc+ $(namePat 'Clash.Sized.Vector.lazyV)+ | isSubj+ , nTy : aTy : _ <- tys+ , _ : xs : _ <- args+ , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm+ [nilCon,_] = tyConDataCons vecTc+ in reduce (mkVecNil nilCon aTy)+ n' -> let (Just vecTc) = UniqMap.lookup vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ in reduce $ mkVecCons consCon aTy n'+ (mkApps (vecHeadPrim vecTcNm)+ [ Right (LitTy (NumTy (n' - 1)))+ , Right aTy+ , Left (valToTerm xs)+ ])+ (mkApps (Prim pInfo)+ [ Right (LitTy (NumTy (n' - 1)))+ , Right aTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (mkApps (vecTailPrim vecTcNm)+ [ Right (LitTy (NumTy (n'-1)))+ , Right aTy+ , Left (valToTerm xs)+ ])+ ])+-- Traversable+ $(namePat 'Clash.Sized.Vector.traverse#)+ | isSubj+ , aTy : fTy : bTy : nTy : _ <- tys+ , apDict : f : xs : _ <- args+ , DC dc vArgs <- xs+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 1) ids+ in reduceWHNF' (mach { mSupply = ids' }) $+ mkApps pureF+ [Right (mkTyConApp (vecTcNm) [nTy,bTy])+ ,Left (mkVecNil dc bTy)]+ _ -> let ((fmapF,apF),ids') = flip runPEM ids $ do+ fDict <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 0+ fmapF' <- mkSelectorCase $(curLoc) is0 tcm fDict 1 0+ apF' <- mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 2+ return (fmapF',apF')+ n'ty = LitTy (NumTy (n-1))+ Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]+ in reduceWHNF' (mach { mSupply = ids' }) $+ mkApps apF+ [Right (mkTyConApp vecTcNm [n'ty,bTy])+ ,Right (mkTyConApp vecTcNm [nTy,bTy])+ ,Left (mkApps fmapF+ [Right bTy+ ,Right (mkFunTy (mkTyConApp vecTcNm [n'ty,bTy])+ (mkTyConApp vecTcNm [nTy,bTy]))+ ,Left (mkApps (Data dc)+ [Right nTy+ ,Right bTy+ ,Right n'ty+ ,Left (primCo consCoTy)])+ ,Left (mkApps (valToTerm f)+ [Left (Either.lefts vArgs !! 1)])+ ])+ ,Left (mkApps (Prim pInfo)+ [Right aTy+ ,Right fTy+ ,Right bTy+ ,Right n'ty+ ,Left (valToTerm apDict)+ ,Left (valToTerm f)+ ,Left (Either.lefts vArgs !! 2)+ ])+ ]+ where+ (tyArgs,_) = splitFunForallTy ty+ TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)+ (ids, is0) = (mSupply mach, mScopeNames mach)++-- BitPack+ $(namePat 'Clash.Sized.Vector.concatBitVector#)+ | isSubj+ , nTy : mTy : _ <- tys+ , _ : km : v : _ <- args+ , DC _ vArgs <- v+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 -> let resTyInfo = extractTySizeInfo tcm ty tys+ in reduce (mkBitVectorLit' resTyInfo 0 0)+ n' | Right m <- runExcept (tyNatSize tcm mTy)+ , (_,tyView -> TyConApp bvTcNm _) <- splitFunForallTy ty+ -> reduceWHNF $+ mkApps (bvAppendPrim bvTcNm)+ [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])+ , Right mTy+ , Left (Literal (NaturalLiteral ((n'-1)*m)))+ , Left (Either.lefts vArgs !! 1)+ , Left (mkApps (Prim pInfo)+ [ Right (LitTy (NumTy (n'-1)))+ , Right mTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (valToTerm km)+ , Left (Either.lefts vArgs !! 2)+ ])+ ]+ _ -> Nothing+ $(namePat 'Clash.Sized.Vector.unconcatBitVector#)+ | isSubj+ , nTy : mTy : _ <- tys+ , _ : km : bv : _ <- args+ , (_,tyView -> TyConApp vecTcNm [_,bvMTy]) <- splitFunForallTy ty+ , TyConApp bvTcNm _ <- tyView bvMTy+ , Right n <- runExcept (tyNatSize tcm nTy)+ -> case n of+ 0 ->+ let (Just vecTc) = UniqMap.lookup vecTcNm tcm+ [nilCon,_] = tyConDataCons vecTc+ in reduce (mkVecNil nilCon (mkTyConApp bvTcNm [mTy]))+ n' | Right m <- runExcept (tyNatSize tcm mTy) ->+ let Just vecTc = UniqMap.lookup vecTcNm tcm+ [_,consCon] = tyConDataCons vecTc+ tupTcNm = ghcTyconToTyConName (tupleTyCon Boxed 2)+ Just tupTc = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ splitCall =+ mkApps (bvSplitPrim bvTcNm)+ [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])+ , Right mTy+ , Left (Literal (NaturalLiteral ((n'-1)*m)))+ , Left (valToTerm bv)+ ]+ mBVTy = mkTyConApp bvTcNm [mTy]+ n1BVTy = mkTyConApp bvTcNm+ [mkTyConApp typeNatMul+ [LitTy (NumTy (n'-1))+ ,mTy]]+ -- Guaranteed no capture, so okay to use unsafe name generation+ xNm = mkUnsafeSystemName "x" 0+ bvNm = mkUnsafeSystemName "bv'" 1+ xId = mkLocalId mBVTy xNm+ bvId = mkLocalId n1BVTy bvNm+ tupPat = DataPat tupDc [] [xId,bvId]+ xAlt = (tupPat, (Var xId))+ bvAlt = (tupPat, (Var bvId))++ in reduce $ mkVecCons consCon (mkTyConApp bvTcNm [mTy]) n'+ (Case splitCall mBVTy [xAlt])+ (mkApps (Prim pInfo)+ [ Right (LitTy (NumTy (n'-1)))+ , Right mTy+ , Left (Literal (NaturalLiteral (n'-1)))+ , Left (valToTerm km)+ , Left (Case splitCall n1BVTy [bvAlt])+ ])+ _ -> Nothing+#if MIN_VERSION_ghc(9,4,0)+ "Data.Text.Show.$wunpackCStringAscii#"+ | [Lit (StringLiteral addr)] <- args+ , Text.Text (Text.ByteArray ba) _off len <- Text.pack addr+ -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+ (Just tupTc) = UniqMap.lookup tupTcNm tcm+ [tupDc] = tyConDataCons tupTc+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [ Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))+ , Left (Literal (IntLiteral 0))+ , Left (Literal (IntLiteral (toInteger len)))])+ in reduce ret+ -- XXX: Does not seem to exist?+ "GHC.Magic.noinlineConstraint"+ | [arg] <- args+ -> reduce (valToTerm arg)+#if MIN_VERSION_base(4,18,0)+ $(namePat 'GHC.TypeNats.withSomeSNat)+ | Lit (NaturalLiteral n) : fun : _ <- args+ , _ : funTy : _ <- Either.rights (fst (splitFunForallTy ty))+ , (tyView -> TyConApp snatTcNm _) : _ <- Either.rights (fst (splitFunForallTy funTy))+ , Just snatTc <- UniqMap.lookup snatTcNm tcm+ , [snatDc] <- tyConDataCons snatTc+ -> let nTy = LitTy (NumTy n)+ snat = mkApps (Data snatDc) [Right nTy, Left (Literal (NaturalLiteral n))]+ ret = mkApps (valToTerm fun) [Right nTy, Left snat]+ in reduce ret+#endif+ -- XXX: Does not seem to exist?+ "GHC.Magic.nospec"+ | [arg] <- args+ -> reduce (valToTerm arg)+ "GHC.Float.$wproperFractionDouble"+ | _ : Lit (DoubleLiteral d) : _ <- args+ , [sty@(tyView -> TyConApp signedTcNm [nTy@(LitTy (NumTy kn))])] <- tys+ , nameOcc signedTcNm == showt ''Signed+ , (_, tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty+ , Just tupTc <- UniqMap.lookup tupTcNm tcm+ , [tupDc] <- tyConDataCons tupTc+ -> let (sn, d1) = reifyNat kn (\p -> first toInteger (op p (wordToDouble d)))+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [ Left (mkSignedLit sty nTy kn sn)+ , Left (mkDoubleCLit tcm (doubleToWord d1) (last tyArgs))+ ])+ in reduce ret+ where+ op :: KnownNat n => Proxy n -> Double -> (Signed n, Double)+ op _ = properFraction+ "GHC.Internal.Float.$wproperFractionDouble"+ | _ : Lit (DoubleLiteral d) : _ <- args+ , [sty@(tyView -> TyConApp signedTcNm [nTy@(LitTy (NumTy kn))])] <- tys+ , nameOcc signedTcNm == showt ''Clash.Sized.Internal.Signed.Signed+ , (_, tyView -> TyConApp tupTcNm tyArgs) <- splitFunForallTy ty+ , Just tupTc <- UniqMap.lookup tupTcNm tcm+ , [tupDc] <- tyConDataCons tupTc+ -> let (sn, d1) = reifyNat kn (\p -> first toInteger (op p (wordToDouble d)))+ ret = mkApps (Data tupDc) (map Right tyArgs +++ [ Left (mkSignedLit sty nTy kn sn)+ , Left (mkDoubleCLit tcm (doubleToWord d1) (last tyArgs))+ ])+ in reduce ret+ where+ op :: KnownNat n => Proxy n -> Double -> (Signed n, Double)+ op _ = properFraction+#endif+ _ -> Nothing+ where+ ty = primType pInfo++ checkNaturalRange1 nTy i f =+ checkNaturalRange nTy [i]+ (\[i'] -> naturalToNaturalLiteral (f i'))++ checkNaturalRange2 nTy i j f =+ checkNaturalRange nTy [i, j]+ (\[i', j'] -> naturalToNaturalLiteral (f i' j'))++ -- Check given integer's range. If any of them are less than zero, give up+ -- and return an undefined type.+ checkNaturalRange+ :: Type+ -- Type of GHC.Natural.Natural ^+ -> [Integer]+ -> ([Natural] -> Term)+ -> Term+ checkNaturalRange nTy natsAsInts f =+ if any (<0) natsAsInts then+ TyApp (Prim NP.undefined) nTy+ else+ f (map fromInteger natsAsInts)++ reduce :: Term -> Maybe Machine+ reduce e = case isX e of+ Left msg -> trace (unlines ["Warning: Not evaluating constant expression:", show (primName pInfo), "Because doing so generates an XException:", msg]) Nothing+ Right e' -> Just (setTerm e' mach)++ reduceWHNF e =+ let eval = Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ mach1@Machine{mStack=[]} = whnf eval tcm isSubj (setTerm e $ stackClear mach)+ in Just $ mach1 { mStack = mStack mach }++ reduceWHNF' mach1 e =+ let eval = Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind+ mach2@Machine{mStack=[]} = whnf eval tcm isSubj (setTerm e mach1)+ in Just $ mach2 { mStack = mStack mach }++ makeUndefinedIf :: Exception e => (e -> Bool) -> Term -> Term+ makeUndefinedIf wantToHandle tm =+ case unsafeDupablePerformIO $ tryJust selectException (evaluate $ force tm) of+ Right b -> b+ Left e -> trace (msg e) (TyApp (Prim NP.undefined) resTy)+ where+ resTy = getResultTy tcm ty tys+ selectException e | wantToHandle e = Just e+ | otherwise = Nothing+ msg e = unlines ["Warning: caught exception: \"" ++ show e ++ "\" while trying to evaluate: "+ , showPpr (mkApps (Prim pInfo) (map (Left . valToTerm) args))+ ]++ catchDivByZero = makeUndefinedIf (==DivideByZero)++-- Helper functions for literals++pairOf :: (Value -> Maybe a) -> [Value] -> Maybe (a, a)+pairOf f [x, y] = (,) <$> f x <*> f y+pairOf _ _ = Nothing++listOf :: (Value -> Maybe a) -> [Value] -> [a]+listOf = mapMaybe++wrapUnsigned :: Integer -> Integer -> Integer+wrapUnsigned n i = i `mod` sz+ where+ sz = 1 `shiftL` fromInteger n++wrapSigned :: Integer -> Integer -> Integer+wrapSigned n i = if n == 0 then 0 else res+ where+ mask = 1 `shiftL` fromInteger (n - 1)+ res = case divMod i mask of+ (s,i1) | even s -> i1+ | otherwise -> i1 - mask++doubleLiterals' :: [Value] -> [Word64]+doubleLiterals' = listOf doubleLiteral++doubleLiteral :: Value -> Maybe Word64+doubleLiteral v = case v of+ Lit (DoubleLiteral i) -> Just i+ _ -> Nothing++floatLiterals' :: [Value] -> [Word32]+floatLiterals' = listOf floatLiteral++floatLiteral :: Value -> Maybe Word32+floatLiteral v = case v of+ Lit (FloatLiteral i) -> Just i+ _ -> Nothing++integerLiterals :: [Value] -> Maybe (Integer, Integer)+integerLiterals = pairOf integerLiteral++integerLiteral :: Value -> Maybe Integer+integerLiteral v =+ case v of+ Lit (IntegerLiteral i) -> Just i+ DC dc [Left (Literal (IntLiteral i))]+ | dcTag dc == 1+ -> Just i+ DC dc [Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))]+ | dcTag dc == 2+#if MIN_VERSION_base(4,15,0)+ -> Just (IP ba)+#else+ -> Just (Jp# (BN# ba))+#endif+ | dcTag dc == 3+#if MIN_VERSION_base(4,15,0)+ -> Just (IN ba)+#else+ -> Just (Jn# (BN# ba))+#endif+ _ -> Nothing++naturalLiterals :: [Value] -> Maybe (Integer, Integer)+naturalLiterals = pairOf naturalLiteral++naturalLiteral :: Value -> Maybe Integer+naturalLiteral v =+ case v of+ Lit (NaturalLiteral i) -> Just i+ DC dc [Left (Literal (WordLiteral i))]+ | dcTag dc == 1+ -> Just i+ DC dc [Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))]+ | dcTag dc == 2+#if MIN_VERSION_base(4,15,0)+ -> Just (IP ba)+#else+ -> Just (Jp# (BN# ba))+#endif+ _ -> Nothing++integerLiterals' :: [Value] -> [Integer]+integerLiterals' = listOf integerLiteral++naturalLiterals' :: [Value] -> [Integer]+naturalLiterals' = listOf naturalLiteral++intLiterals :: [Value] -> Maybe (Integer,Integer)+intLiterals = pairOf intLiteral++intLiterals' :: [Value] -> [Integer]+intLiterals' = listOf intLiteral++intCLiterals' :: [Value] -> [Integer]+intCLiterals' = listOf intCLiteral++intLiteral :: Value -> Maybe Integer+intLiteral x = case x of+ Lit (IntLiteral i) -> Just i+ _ -> Nothing++#if MIN_VERSION_base(4,16,0)+int8Literals' :: [Value] -> [Integer]+int8Literals' = listOf int8Literal++int8Literal :: Value -> Maybe Integer+int8Literal x = case x of+ Lit (Int8Literal i) -> Just i+ _ -> Nothing++int16Literals' :: [Value] -> [Integer]+int16Literals' = listOf int16Literal++int16Literal :: Value -> Maybe Integer+int16Literal x = case x of+ Lit (Int16Literal i) -> Just i+ _ -> Nothing++int32Literals' :: [Value] -> [Integer]+int32Literals' = listOf int32Literal++int32Literal :: Value -> Maybe Integer+int32Literal x = case x of+ Lit (Int32Literal i) -> Just i+ _ -> Nothing++#if MIN_VERSION_base(4,17,0)+int64Literals' :: [Value] -> [Integer]+int64Literals' = listOf int64Literal++int64Literal :: Value -> Maybe Integer+int64Literal x = case x of+ Lit (Int64Literal i) -> Just i+ _ -> Nothing+#endif+#endif++intCLiteral :: Value -> Maybe Integer+intCLiteral v = case v of+ (DC _ [Left (Literal (IntLiteral i))]) -> Just i+ _ -> Nothing++intCLiterals :: [Value] -> Maybe (Integer, Integer)+intCLiterals = pairOf intCLiteral++wordLiterals :: [Value] -> Maybe (Integer,Integer)+wordLiterals = pairOf wordLiteral++wordLiterals' :: [Value] -> [Integer]+wordLiterals' = listOf wordLiteral++wordLiteral :: Value -> Maybe Integer+wordLiteral x = case x of+ Lit (WordLiteral i) -> Just i+ _ -> Nothing++#if MIN_VERSION_base(4,16,0)+word8Literals' :: [Value] -> [Integer]+word8Literals' = listOf word8Literal++word8Literal :: Value -> Maybe Integer+word8Literal x = case x of+ Lit (Word8Literal i) -> Just i+ _ -> Nothing++word16Literals' :: [Value] -> [Integer]+word16Literals' = listOf word16Literal++word16Literal :: Value -> Maybe Integer+word16Literal x = case x of+ Lit (Word16Literal i) -> Just i+ _ -> Nothing++word32Literals' :: [Value] -> [Integer]+word32Literals' = listOf word32Literal++word32Literal :: Value -> Maybe Integer+word32Literal x = case x of+ Lit (Word32Literal i) -> Just i+ _ -> Nothing+#endif++word64Literals' :: [Value] -> [Integer]+word64Literals' = listOf word64Literal++#if MIN_VERSION_base(4,17,0)+word64Literal :: Value -> Maybe Integer+word64Literal x = case x of+ Lit (Word64Literal i) -> Just i+ _ -> Nothing+#else+-- Prior to GHC 9.4 Word64# didn't exist, 64 bit primitives took Word# instead+word64Literal :: Value -> Maybe Integer+word64Literal= wordLiteral+#endif++charLiterals :: [Value] -> Maybe (Char,Char)+charLiterals = pairOf charLiteral++charLiterals' :: [Value] -> [Char]+charLiterals' = listOf charLiteral++charLiteral :: Value -> Maybe Char+charLiteral x = case x of+ Lit (CharLiteral c) -> Just c+ _ -> Nothing++sizedLiterals :: Text -> [Value] -> Maybe (Integer,Integer)+sizedLiterals szCon = pairOf (sizedLiteral szCon)++sizedLiterals' :: Text -> [Value] -> [Integer]+sizedLiterals' szCon = listOf (sizedLiteral szCon)++sizedLiteral :: Text -> Value -> Maybe Integer+sizedLiteral szCon val = case val of+ PrimVal p _ [_, Lit (IntegerLiteral i)]+ | primName p == szCon -> Just i+ _ -> Nothing++bitLiterals+ :: [Value]+ -> [(Integer,Integer)]+bitLiterals = map normalizeBit . mapMaybe go+ where+ normalizeBit (msk,v) = (msk .&. 1, v .&. 1)+ go val = case val of+ PrimVal p _ [Lit (WordLiteral m), Lit (IntegerLiteral i)]+ | primName p == showt 'Clash.Sized.Internal.BitVector.fromInteger##+ -> Just (m,i)+ _ -> Nothing++indexLiterals, signedLiterals, unsignedLiterals+ :: [Value] -> Maybe (Integer,Integer)+indexLiterals = sizedLiterals (showt 'Clash.Sized.Internal.Index.fromInteger#)+signedLiterals = sizedLiterals (showt 'Clash.Sized.Internal.Signed.fromInteger#)+unsignedLiterals = sizedLiterals (showt 'Clash.Sized.Internal.Unsigned.fromInteger#)++indexLiterals', signedLiterals', unsignedLiterals'+ :: [Value] -> [Integer]+indexLiterals' = sizedLiterals' (showt 'Clash.Sized.Internal.Index.fromInteger#)+signedLiterals' = sizedLiterals' (showt 'Clash.Sized.Internal.Signed.fromInteger#)+unsignedLiterals' = sizedLiterals' (showt 'Clash.Sized.Internal.Unsigned.fromInteger#)++bitVectorLiterals'+ :: [Value] -> [(Integer,Integer)]+bitVectorLiterals' = listOf bitVectorLiteral++bitVectorLiteral :: Value -> Maybe (Integer, Integer)+bitVectorLiteral val = case val of+ (PrimVal p _ [_, Lit (NaturalLiteral m), Lit (IntegerLiteral i)])+ | primName p == showt 'Clash.Sized.Internal.BitVector.fromInteger# -> Just (m, i)+ _ -> Nothing++toBV :: (Integer,Integer) -> BitVector n+toBV (mask,val) = BV (fromInteger mask) (fromInteger val)++splitBV :: BitVector n -> (Integer,Integer)+splitBV (BV msk val) = (toInteger msk, toInteger val)++toBit :: (Integer,Integer) -> Bit+toBit (mask,val) = Bit (fromInteger mask) (fromInteger val)++valArgs+ :: Value+ -> Maybe [Term]+valArgs v =+ case v of+ PrimVal _ _ vs -> Just (fmap valToTerm vs)+ DC _ args -> Just (Either.lefts args)+ _ -> Nothing++-- Tries to match literal arguments to a function like+-- (Unsigned.shiftL# :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n)+sizedLitIntLit+ :: Text -> TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,Integer,Integer)+sizedLitIntLit szCon tcm tys args+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [_+ ,PrimVal p _ [_,Lit (IntegerLiteral i)]+ ,valArgs -> Just [Literal (IntLiteral j)]+ ] <- args+ , primName p == szCon+ = Just (nTy,kn,i,j)+ | otherwise+ = Nothing++signedLitIntLit, unsignedLitIntLit+ :: TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,Integer,Integer)+signedLitIntLit = sizedLitIntLit (showt 'Clash.Sized.Internal.Signed.fromInteger#)+unsignedLitIntLit = sizedLitIntLit (showt 'Clash.Sized.Internal.Unsigned.fromInteger#)++bitVectorLitIntLit+ :: TyConMap -> [Type] -> [Value]+ -> Maybe (Type,Integer,(Integer,Integer),Integer)+bitVectorLitIntLit tcm tys args+ | Just (nTy,kn) <- extractKnownNat tcm tys+ , [_+ ,PrimVal p _ [_,Lit (NaturalLiteral m),Lit (IntegerLiteral i)]+ ,valArgs -> Just [Literal (IntLiteral j)]+ ] <- args+ , primName p == showt 'Clash.Sized.Internal.BitVector.fromInteger#+ = Just (nTy,kn,(m,i),j)+ | otherwise+ = Nothing++mkIntCLit :: TyConMap -> Integer -> Type -> Term+mkIntCLit tcm lit resTy =+ App (Data intDc) (Literal (IntLiteral lit))+ where+ (_, tyView -> TyConApp intTcNm []) = splitFunForallTy resTy+ Just intTc = UniqMap.lookup intTcNm tcm+ [intDc] = tyConDataCons intTc++mkFloatCLit :: TyConMap -> Word32 -> Type -> Term+mkFloatCLit tcm lit resTy =+ App (Data floatDc) (Literal (FloatLiteral lit))+ where+ (_, tyView -> TyConApp floatTcNm []) = splitFunForallTy resTy+ (Just floatTc) = UniqMap.lookup floatTcNm tcm+ [floatDc] = tyConDataCons floatTc++mkDoubleCLit :: TyConMap -> Word64 -> Type -> Term+mkDoubleCLit tcm lit resTy =+ App (Data doubleDc) (Literal (DoubleLiteral lit))+ where+ (_, tyView -> TyConApp doubleTcNm []) = splitFunForallTy resTy+ (Just doubleTc) = UniqMap.lookup doubleTcNm tcm+ [doubleDc] = tyConDataCons doubleTc++mkSomeNat :: TyConMap -> Integer -> Type -> Term+mkSomeNat tcm lit resTy =+ mkApps (Data someNatDc)+ [ Right (LitTy (NumTy lit))+ , Left (Literal (NaturalLiteral lit))+ , Left proxy+ ]+ where+ -- Get the SomeNat data constructor+ TyConApp someNatTcNm [] = tyView resTy+ (Just someNatTc) = UniqMap.lookup someNatTcNm tcm+ [someNatDc] = tyConDataCons someNatTc++ -- Get the Proxy data constructor+ (_:_:Right (tyView -> TyConApp proxyTcNm [natTy,_]):_,_) =+ splitFunForallTy (dcType someNatDc)+ (Just proxyTc) = UniqMap.lookup proxyTcNm tcm+ [proxyDc] = tyConDataCons proxyTc++ -- Build the Proxy argument+ proxy = mkApps (Data proxyDc)+ [ Right natTy+ , Right (LitTy (NumTy lit))+ ]++-- From an argument list to function of type+-- forall n. KnownNat n => ...+-- extract (nTy,nInt)+-- where nTy is the Type of n+-- and nInt is its value as an Integer+extractKnownNat :: TyConMap -> [Type] -> Maybe (Type, Integer)+extractKnownNat tcm tys = case tys of+ nTy : _ | Right nInt <- runExcept (tyNatSize tcm nTy)+ -> Just (nTy, nInt)+ _ -> Nothing++-- From an argument list to function of type+-- forall n m o .. . (KnownNat n, KnownNat m, KnownNat o, ..) => ...+-- extract [(nTy,nInt), (mTy,mInt), (oTy,oInt)]+-- where nTy is the Type of n+-- and nInt is its value as an Integer+extractKnownNats :: TyConMap -> [Type] -> [(Type, Integer)]+extractKnownNats tcm =+ mapMaybe (extractKnownNat tcm . pure)++-- Construct a constant term of a sized type+mkSizedLit+ :: (Type -> Term)+ -- ^ Type constructor?+ -> Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Term+mkSizedLit conPrim ty nTy kn val =+ mkApps+ (conPrim sTy)+ [ Right nTy+ , Left (Literal (NaturalLiteral kn))+ , Left (Literal (IntegerLiteral val)) ]+ where+ (_,sTy) = splitFunForallTy ty++mkBitLit+ :: Type+ -- ^ Result type+ -> Integer+ -- ^ Mask+ -> Integer+ -- ^ Value+ -> Term+mkBitLit ty msk val =+ mkApps (bConPrim sTy) [ Left (Literal (WordLiteral (msk .&. 1)))+ , Left (Literal (IntegerLiteral (val .&. 1)))]+ where+ (_,sTy) = splitFunForallTy ty++mkSignedLit, mkUnsignedLit+ :: Type+ -- Result type+ -> Type+ -- forall n.+ -> Integer+ -- KnownNat n+ -> Integer+ -- Value+ -> Term+mkSignedLit = mkSizedLit signedConPrim+mkUnsignedLit = mkSizedLit unsignedConPrim++mkBitVectorLit+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ mask+ -> Integer+ -- ^ Value to construct+ -> Term+mkBitVectorLit ty nTy kn mask val+ = mkApps (bvConPrim sTy)+ [Right nTy+ ,Left (Literal (NaturalLiteral kn))+ ,Left (Literal (NaturalLiteral mask))+ ,Left (Literal (IntegerLiteral val))]+ where+ (_,sTy) = splitFunForallTy ty++mkIndexLitE+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Either Term Term+ -- ^ Either undefined (if given value is out of bounds of given type) or term+ -- representing literal+mkIndexLitE rTy nTy kn val+ | val >= 0+ , val < kn+ = Right (mkSizedLit indexConPrim rTy nTy kn val)+ | otherwise+ = Left (TyApp (Prim NP.undefined) (mkTyConApp indexTcNm [nTy]))+ where+ TyConApp indexTcNm _ = tyView (snd (splitFunForallTy rTy))++mkIndexLit+ :: Type+ -- ^ Result type+ -> Type+ -- ^ forall n.+ -> Integer+ -- ^ KnownNat n+ -> Integer+ -- ^ Value to construct+ -> Term+mkIndexLit rTy nTy kn val =+ either id id (mkIndexLitE rTy nTy kn val)++mkBitVectorLit'+ :: (Type, Type, Integer)+ -- ^ (result type, forall n., KnownNat n)+ -> Integer+ -- ^ Mask+ -> Integer+ -- ^ Value+ -> Term+mkBitVectorLit' (ty,nTy,kn) = mkBitVectorLit ty nTy kn++mkIndexLit'+ :: (Type, Type, Integer)+ -- ^ (result type, forall n., KnownNat n)+ -> Integer+ -- ^ value+ -> Term+mkIndexLit' (rTy,nTy,kn) = mkIndexLit rTy nTy kn++boolToIntLiteral :: Bool -> Term+boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0)++boolToBoolLiteral :: TyConMap -> Type -> Bool -> Term+boolToBoolLiteral tcm ty b =+ let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty+ (Just boolTc) = UniqMap.lookup boolTcNm tcm+ [falseDc,trueDc] = tyConDataCons boolTc+ retDc = if b then trueDc else falseDc+ in Data retDc++charToCharLiteral :: Char -> Term+charToCharLiteral = Literal . CharLiteral++integerToIntLiteral :: Integer -> Term+integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behavior++integerToWordLiteral :: Integer -> Term+integerToWordLiteral = Literal . WordLiteral . toInteger . (fromInteger :: Integer -> Word) -- for overflow behavior++#if MIN_VERSION_base(4,17,0) || WORD_SIZE_IN_BITS < 64+integerToInt64Literal :: Integer -> Term+integerToInt64Literal = Literal . Int64Literal . toInteger . (fromInteger :: Integer -> Int64) -- for overflow behavior++integerToWord64Literal :: Integer -> Term+integerToWord64Literal = Literal . Word64Literal . toInteger . (fromInteger :: Integer -> Word64) -- for overflow behavior+#endif++integerToIntegerLiteral :: Integer -> Term+integerToIntegerLiteral = Literal . IntegerLiteral++naturalToNaturalLiteral :: Natural -> Term+naturalToNaturalLiteral = Literal . NaturalLiteral . toInteger++bConPrim :: Type -> Term+bConPrim (tyView -> TyConApp bTcNm _)+ = Prim (PrimInfo (showt 'Clash.Sized.Internal.BitVector.fromInteger##) funTy WorkNever SingleResult NoUnfolding)+ where+ funTy = foldr1 mkFunTy [wordPrimTy,integerPrimTy,mkTyConApp bTcNm []]+bConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++bvConPrim :: Type -> Term+bvConPrim (tyView -> TyConApp bvTcNm _)+ = Prim (PrimInfo (showt 'Clash.Sized.Internal.BitVector.fromInteger#) (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,naturalPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+bvConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++indexConPrim :: Type -> Term+indexConPrim (tyView -> TyConApp indexTcNm _)+ = Prim (PrimInfo (showt 'Clash.Sized.Internal.Index.fromInteger#) (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+indexConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++signedConPrim :: Type -> Term+signedConPrim (tyView -> TyConApp signedTcNm _)+ = Prim (PrimInfo (showt 'Clash.Sized.Internal.Signed.fromInteger#) (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+signedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++unsignedConPrim :: Type -> Term+unsignedConPrim (tyView -> TyConApp unsignedTcNm _)+ = Prim (PrimInfo (showt 'Clash.Sized.Internal.Unsigned.fromInteger#) (ForAllTy nTV funTy) WorkNever SingleResult NoUnfolding)+ where+ funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]]+ nName = mkUnsafeSystemName "n" 0+ nVar = VarTy nTV+ nTV = mkTyVar typeNatKind nName+unsignedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"+++-- | Lift a binary function over 'Unsigned' values to be used as literal Evaluator+--+--+liftUnsigned2 :: KnownNat n+ => (Unsigned n -> Unsigned n -> Unsigned n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftUnsigned2 = liftSized2 unsignedLiterals' mkUnsignedLit++liftSigned2 :: KnownNat n+ => (Signed n -> Signed n -> Signed n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftSigned2 = liftSized2 signedLiterals' mkSignedLit++liftBitVector2 :: KnownNat n+ => (BitVector n -> BitVector n -> BitVector n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftBitVector2 f ty tcm tys args _p+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i,j] <- bitVectorLiterals' args+ = let BV mask val = f (toBV i) (toBV j)+ in Just $ mkBitVectorLit ty nTy kn (toInteger mask) (toInteger val)+ | otherwise = Nothing++liftBitVector2Bool :: KnownNat n+ => (BitVector n -> BitVector n -> Bool)+ -> Type+ -> TyConMap+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftBitVector2Bool f ty tcm args _p+ | [i,j] <- bitVectorLiterals' args+ = let val = f (toBV i) (toBV j)+ in Just $ boolToBoolLiteral tcm ty val+ | otherwise = Nothing++liftInteger2BitVector+ :: KnownNat n+ => (Integer -> BitVector n)+ -> (Type, Type, Integer)+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftInteger2BitVector f resTyInfo args _p+ | [i] <- intCLiterals' args+ = let BV msk val = f i+ in Just (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))++ | otherwise+ = Nothing++liftBitVector2CInt+ :: KnownNat n+ => TyConMap+ -> Type+ -> (BitVector n -> Integer)+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftBitVector2CInt tcm resTy f args _p+ | [i] <- bitVectorLiterals' args+ = let val = f (toBV i)+ in Just $ mkIntCLit tcm val resTy+ | otherwise+ = Nothing++liftSized2 :: (KnownNat n, Integral (sized n))+ => ([Value] -> [Integer])+ -- ^ literal argument extraction function+ -> (Type -> Type -> Integer -> Integer -> Term)+ -- ^ literal contruction function+ -> (sized n -> sized n -> sized n)+ -> Type+ -> TyConMap+ -> [Type]+ -> [Value]+ -> (Proxy n -> Maybe Term)+liftSized2 extractLitArgs mkLit f ty tcm tys args p+ | Just (nTy, kn) <- extractKnownNat tcm tys+ , [i,j] <- extractLitArgs args+ = let val = runSizedF f i j p+ in Just $ mkLit ty nTy kn val+ | otherwise = Nothing++-- | Helper to run a function over sized types on integers+--+-- This only works on function of type (sized n -> sized n -> sized n)+-- The resulting function must be executed with reifyNat+runSizedF+ :: (KnownNat n, Integral (sized n))+ => (sized n -> sized n -> sized n)+ -- ^ function to run+ -> Integer+ -- ^ first argument+ -> Integer+ -- ^ second argument+ -> (Proxy n -> Integer)+runSizedF f i j _ = toInteger $ f (fromInteger i) (fromInteger j)++extractTySizeInfo :: TyConMap -> Type -> [Type] -> (Type, Type, Integer)+extractTySizeInfo tcm ty tys = (resTy,resSizeTy,resSize)+ where+ ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'+ TyConApp _ [resSizeTy] = tyView resTy+ Right resSize = runExcept (tyNatSize tcm resSizeTy)++getResultTy+ :: TyConMap+ -> Type+ -> [Type]+ -> Type+getResultTy tcm ty tys = resTy+ where+ ty' = piResultTys tcm ty tys+ (_,resTy) = splitFunForallTy ty'++liftDDI :: (Double# -> Double# -> Int#) -> [Value] -> Maybe Term+liftDDI f args = case doubleLiterals' args of+ [i,j] -> Just $ runDDI f i j+ _ -> Nothing+liftDDD :: (Double# -> Double# -> Double#) -> [Value] -> Maybe Term+liftDDD f args = case doubleLiterals' args of+ [i,j] -> Just $ runDDD f i j+ _ -> Nothing+liftDD :: (Double# -> Double#) -> [Value] -> Maybe Term+liftDD f args = case doubleLiterals' args of+ [i] -> Just $ runDD f i+ _ -> Nothing+runDDI :: (Double# -> Double# -> Int#) -> Word64 -> Word64 -> Term+runDDI f i j+ = let !(D# a) = wordToDouble i+ !(D# b) = wordToDouble j+ r = f a b+ in Literal . IntLiteral . toInteger $ I# r+runDDD :: (Double# -> Double# -> Double#) -> Word64 -> Word64 -> Term+runDDD f i j+ = let !(D# a) = wordToDouble i+ !(D# b) = wordToDouble j+ r = f a b+ in Literal . DoubleLiteral . doubleToWord $ D# r+runDD :: (Double# -> Double#) -> Word64 -> Term+runDD f i+ = let !(D# a) = wordToDouble i+ r = f a+ in Literal . DoubleLiteral . doubleToWord $ D# r++liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term+liftFFI f args = case floatLiterals' args of+ [i,j] -> Just $ runFFI f i j+ _ -> Nothing+liftFFF :: (Float# -> Float# -> Float#) -> [Value] -> Maybe Term+liftFFF f args = case floatLiterals' args of+ [i,j] -> Just $ runFFF f i j+ _ -> Nothing+liftFF :: (Float# -> Float#) -> [Value] -> Maybe Term+liftFF f args = case floatLiterals' args of+ [i] -> Just $ runFF f i+ _ -> Nothing+runFFI :: (Float# -> Float# -> Int#) -> Word32 -> Word32 -> Term+runFFI f i j+ = let !(F# a) = wordToFloat i+ !(F# b) = wordToFloat j+ r = f a b+ in Literal . IntLiteral . toInteger $ I# r+runFFF :: (Float# -> Float# -> Float#) -> Word32 -> Word32 -> Term+runFFF f i j+ = let !(F# a) = wordToFloat i+ !(F# b) = wordToFloat j+ r = f a b+ in Literal . FloatLiteral . floatToWord $ F# r+runFF :: (Float# -> Float#) -> Word32 -> Term+runFF f i+ = let !(F# a) = wordToFloat i+ r = f a+ in Literal . FloatLiteral . floatToWord $ F# r++#if MIN_VERSION_base(4,16,0)+liftI8 :: (Int8# -> Int8# -> Int8#) -> [Value] -> Maybe Term+liftI8 f args = case int8Literals' args of+ [i,j] ->+ let !(I8# a) = fromInteger i+ !(I8# b) = fromInteger j+ in Just (Literal (Int8Literal (toInteger (I8# (f a b)))))+ _ -> Nothing++liftI8I :: (Int8# -> Int# -> Int8#) -> [Value] -> Maybe Term+liftI8I f args = case args of+ [Lit (Int8Literal i),Lit (IntLiteral j)] ->+ let !(I8# a) = fromInteger i+ !(I# b) = fromInteger j+ in Just (Literal (Int8Literal (toInteger (I8# (f a b)))))+ _ -> Nothing++liftI8RI :: (Int8# -> Int8# -> Int#) -> [Value] -> Maybe Term+liftI8RI f args = case int8Literals' args of+ [i,j] ->+ let !(I8# a) = fromInteger i+ !(I8# b) = fromInteger j+ in Just (Literal (IntLiteral (toInteger (I# (f a b)))))+ _ -> Nothing++liftI16 :: (Int16# -> Int16# -> Int16#) -> [Value] -> Maybe Term+liftI16 f args = case int16Literals' args of+ [i,j] ->+ let !(I16# a) = fromInteger i+ !(I16# b) = fromInteger j+ in Just (Literal (Int16Literal (toInteger (I16# (f a b)))))+ _ -> Nothing++liftI16I :: (Int16# -> Int# -> Int16#) -> [Value] -> Maybe Term+liftI16I f args = case args of+ [Lit (Int16Literal i),Lit (IntLiteral j)] ->+ let !(I16# a) = fromInteger i+ !(I# b) = fromInteger j+ in Just (Literal (Int16Literal (toInteger (I16# (f a b)))))+ _ -> Nothing++liftI16RI :: (Int16# -> Int16# -> Int#) -> [Value] -> Maybe Term+liftI16RI f args = case int16Literals' args of+ [i,j] ->+ let !(I16# a) = fromInteger i+ !(I16# b) = fromInteger j+ in Just (Literal (IntLiteral (toInteger (I# (f a b)))))+ _ -> Nothing++liftI32 :: (Int32# -> Int32# -> Int32#) -> [Value] -> Maybe Term+liftI32 f args = case int32Literals' args of+ [i,j] ->+ let !(I32# a) = fromInteger i+ !(I32# b) = fromInteger j+ in Just (Literal (Int32Literal (toInteger (I32# (f a b)))))+ _ -> Nothing++liftI32I :: (Int32# -> Int# -> Int32#) -> [Value] -> Maybe Term+liftI32I f args = case args of+ [Lit (Int32Literal i),Lit (IntLiteral j)] ->+ let !(I32# a) = fromInteger i+ !(I# b) = fromInteger j+ in Just (Literal (Int32Literal (toInteger (I32# (f a b)))))+ _ -> Nothing++liftI32RI :: (Int32# -> Int32# -> Int#) -> [Value] -> Maybe Term+liftI32RI f args = case int32Literals' args of+ [i,j] ->+ let !(I32# a) = fromInteger i+ !(I32# b) = fromInteger j+ in Just (Literal (IntLiteral (toInteger (I# (f a b)))))+ _ -> Nothing++#if MIN_VERSION_base(4,17,0)+liftI64 :: (Int64# -> Int64# -> Int64#) -> [Value] -> Maybe Term+liftI64 f args = case int64Literals' args of+ [i,j] ->+ let !(I64# a) = fromInteger i+ !(I64# b) = fromInteger j+ in Just (Literal (Int64Literal (toInteger (I64# (f a b)))))+ _ -> Nothing++liftI64I :: (Int64# -> Int# -> Int64#) -> [Value] -> Maybe Term+liftI64I f args = case args of+ [Lit (Int64Literal i),Lit (IntLiteral j)] ->+ let !(I64# a) = fromInteger i+ !(I# b) = fromInteger j+ in Just (Literal (Int64Literal (toInteger (I64# (f a b)))))+ _ -> Nothing++liftI64RI :: (Int64# -> Int64# -> Int#) -> [Value] -> Maybe Term+liftI64RI f args = case int64Literals' args of+ [i,j] ->+ let !(I64# a) = fromInteger i+ !(I64# b) = fromInteger j+ in Just (Literal (IntLiteral (toInteger (I# (f a b)))))+ _ -> Nothing+#endif++liftW8 :: (Word8# -> Word8# -> Word8#) -> [Value] -> Maybe Term+liftW8 f args = case word8Literals' args of+ [i,j] ->+ let !(W8# a) = fromInteger i+ !(W8# b) = fromInteger j+ in Just (Literal (Word8Literal (toInteger (W8# (f a b)))))+ _ -> Nothing++liftW8I :: (Word8# -> Int# -> Word8#) -> [Value] -> Maybe Term+liftW8I f args = case args of+ [Lit (Word8Literal i),Lit (IntLiteral j)] ->+ let !(W8# a) = fromInteger i+ !(I# b) = fromInteger j+ in Just (Literal (Word8Literal (toInteger (W8# (f a b)))))+ _ -> Nothing++liftW8RI :: (Word8# -> Word8# -> Int#) -> [Value] -> Maybe Term+liftW8RI f args = case word8Literals' args of+ [i,j] ->+ let !(W8# a) = fromInteger i+ !(W8# b) = fromInteger j+ in Just (Literal (IntLiteral (toInteger (I# (f a b)))))+ _ -> Nothing++liftW16 :: (Word16# -> Word16# -> Word16#) -> [Value] -> Maybe Term+liftW16 f args = case word16Literals' args of+ [i,j] -> let !(W16# a) = fromInteger i+ !(W16# b) = fromInteger j+ in Just (Literal (Word16Literal (toInteger (W16# (f a b)))))+ _ -> Nothing++liftW16I :: (Word16# -> Int# -> Word16#) -> [Value] -> Maybe Term+liftW16I f args = case args of+ [Lit (Word16Literal i),Lit (IntLiteral j)] ->+ let !(W16# a) = fromInteger i+ !(I# b) = fromInteger j+ in Just (Literal (Word16Literal (toInteger (W16# (f a b)))))+ _ -> Nothing++liftW16RI :: (Word16# -> Word16# -> Int#) -> [Value] -> Maybe Term+liftW16RI f args = case word16Literals' args of+ [i,j] ->+ let !(W16# a) = fromInteger i+ !(W16# b) = fromInteger j+ in Just (Literal (IntLiteral (toInteger (I# (f a b)))))+ _ -> Nothing++liftW32 :: (Word32# -> Word32# -> Word32#) -> [Value] -> Maybe Term+liftW32 f args = case word32Literals' args of+ [i,j] -> let !(W32# a) = fromInteger i+ !(W32# b) = fromInteger j+ in Just (Literal (Word32Literal (toInteger (W32# (f a b)))))+ _ -> Nothing++liftW32I :: (Word32# -> Int# -> Word32#) -> [Value] -> Maybe Term+liftW32I f args = case args of+ [Lit (Word32Literal i),Lit (IntLiteral j)] ->+ let !(W32# a) = fromInteger i+ !(I# b) = fromInteger j+ in Just (Literal (Word32Literal (toInteger (W32# (f a b)))))+ _ -> Nothing++liftW32RI :: (Word32# -> Word32# -> Int#) -> [Value] -> Maybe Term+liftW32RI f args = case word32Literals' args of+ [i,j] ->+ let !(W32# a) = fromInteger i+ !(W32# b) = fromInteger j+ in Just (Literal (IntLiteral (toInteger (I# (f a b)))))+ _ -> Nothing++#if MIN_VERSION_base(4,17,0)+liftW64 :: (Word64# -> Word64# -> Word64#) -> [Value] -> Maybe Term+liftW64 f args = case word64Literals' args of+ [i,j] -> let !(W64# a) = fromInteger i+ !(W64# b) = fromInteger j+ in Just (Literal (Word64Literal (toInteger (W64# (f a b)))))+ _ -> Nothing++liftW64I :: (Word64# -> Int# -> Word64#) -> [Value] -> Maybe Term+liftW64I f args = case args of+ [Lit (Word64Literal i),Lit (IntLiteral j)] ->+ let !(W64# a) = fromInteger i+ !(I# b) = fromInteger j+ in Just (Literal (Word64Literal (toInteger (W64# (f a b)))))+ _ -> Nothing++liftW64RI :: (Word64# -> Word64# -> Int#) -> [Value] -> Maybe Term+liftW64RI f args = case word64Literals' args of+ [i,j] ->+ let !(W64# a) = fromInteger i+ !(W64# b) = fromInteger j+ in Just (Literal (IntLiteral (toInteger (I# (f a b)))))+ _ -> Nothing+#endif+#endif++splitAtPrim+ :: TyConName+ -- ^ SNat TyCon name+ -> TyConName+ -- ^ Vec TyCon name+ -> Term+splitAtPrim snatTcNm vecTcNm =+ Prim (PrimInfo (showt 'Clash.Sized.Vector.splitAt) (splitAtTy snatTcNm vecTcNm) WorkNever SingleResult NoUnfolding)++splitAtTy+ :: TyConName+ -- ^ SNat TyCon name+ -> TyConName+ -- ^ Vec TyCon name+ -> Type+splitAtTy snatNm vecNm =+ ForAllTy mTV (+ ForAllTy nTV (+ ForAllTy aTV (+ mkFunTy+ (mkTyConApp snatNm [VarTy mTV])+ (mkFunTy+ (mkTyConApp vecNm+ [mkTyConApp typeNatAdd+ [VarTy mTV+ ,VarTy nTV]+ ,VarTy aTV])+ (mkTyConApp tupNm+ [mkTyConApp vecNm+ [VarTy mTV+ ,VarTy aTV]+ ,mkTyConApp vecNm+ [VarTy nTV+ ,VarTy aTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++foldSplitAtTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+foldSplitAtTy vecNm =+ ForAllTy mTV (+ ForAllTy nTV (+ ForAllTy aTV (+ mkFunTy+ naturalPrimTy+ (mkFunTy+ (mkTyConApp vecNm+ [mkTyConApp typeNatAdd+ [VarTy mTV+ ,VarTy nTV]+ ,VarTy aTV])+ (mkTyConApp tupNm+ [mkTyConApp vecNm+ [VarTy mTV+ ,VarTy aTV]+ ,mkTyConApp vecNm+ [VarTy nTV+ ,VarTy aTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++vecAppendPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecAppendPrim vecNm =+ Prim (PrimInfo (showt '(Clash.Sized.Vector.++)) (vecAppendTy vecNm) WorkNever SingleResult NoUnfolding)++vecAppendTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+vecAppendTy vecNm =+ ForAllTy nTV (+ ForAllTy aTV (+ ForAllTy mTV (+ mkFunTy+ (mkTyConApp vecNm [VarTy nTV+ ,VarTy aTV+ ])+ (mkFunTy+ (mkTyConApp vecNm [VarTy mTV+ ,VarTy aTV+ ])+ (mkTyConApp vecNm [mkTyConApp typeNatAdd+ [VarTy nTV+ ,VarTy mTV]+ ,VarTy aTV+ ])))))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 2)++vecZipWithPrim+ :: TyConName+ -- ^ Vec TyCon name+ -> Term+vecZipWithPrim vecNm =+ Prim (PrimInfo (showt 'Clash.Sized.Vector.zipWith) (vecZipWithTy vecNm) WorkNever SingleResult NoUnfolding)++vecZipWithTy+ :: TyConName+ -- ^ Vec TyCon name+ -> Type+vecZipWithTy vecNm =+ ForAllTy aTV (+ ForAllTy bTV (+ ForAllTy cTV (+ ForAllTy nTV (+ mkFunTy+ (mkFunTy aTy (mkFunTy bTy cTy))+ (mkFunTy+ (mkTyConApp vecNm [nTy,aTy])+ (mkFunTy+ (mkTyConApp vecNm [nTy,bTy])+ (mkTyConApp vecNm [nTy,cTy])))))))+ where+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)+ bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1)+ cTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "c" 2)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 3)+ aTy = VarTy aTV+ bTy = VarTy bTV+ cTy = VarTy cTV+ nTy = VarTy nTV++vecImapGoTy+ :: TyConName+ -- ^ Vec TyCon name+ -> TyConName+ -- ^ Index TyCon name+ -> Type+vecImapGoTy vecTcNm indexTcNm =+ ForAllTy nTV (+ ForAllTy mTV (+ ForAllTy aTV (+ ForAllTy bTV (+ mkFunTy fTy+ (mkFunTy vecATy (mkFunTy indexTy vecBTy))))))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)+ aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 2)+ bTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 3)+ indexTy = mkTyConApp indexTcNm [nTy]+ nTy = VarTy nTV+ mTy = VarTy mTV+ fTy = mkFunTy indexTy (mkFunTy aTy bTy)+ aTy = VarTy aTV+ bTy = VarTy bTV+ vecATy = mkTyConApp vecTcNm [mTy,aTy]+ vecBTy = mkTyConApp vecTcNm [mTy,bTy]++indexAddTy+ :: TyConName+ -- ^ Index TyCon name+ -> Type+indexAddTy indexTcNm =+ ForAllTy nTV (+ mkFunTy naturalPrimTy (mkFunTy indexTy (mkFunTy indexTy indexTy)))+ where+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+ indexTy = mkTyConApp indexTcNm [VarTy nTV]++bvAppendPrim+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Term+bvAppendPrim bvTcNm =+ Prim (PrimInfo (showt '(Clash.Sized.Internal.BitVector.++#)) (bvAppendTy bvTcNm) WorkNever SingleResult NoUnfolding)++bvAppendTy+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Type+bvAppendTy bvNm =+ ForAllTy mTV (+ ForAllTy nTV (+ mkFunTy naturalPrimTy (mkFunTy+ (mkTyConApp bvNm [VarTy nTV])+ (mkFunTy+ (mkTyConApp bvNm [VarTy mTV])+ (mkTyConApp bvNm [mkTyConApp typeNatAdd+ [VarTy nTV+ ,VarTy mTV]])))))+ where+ mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+ nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)++bvSplitPrim+ :: TyConName+ -- ^ BitVector TyCon Name+ -> Term+bvSplitPrim bvTcNm =+ Prim (PrimInfo (showt 'Clash.Sized.Internal.BitVector.split#) (bvSplitTy bvTcNm) WorkNever SingleResult NoUnfolding) bvSplitTy :: TyConName