packages feed

clash-ghc 1.2.1 → 1.2.2

raw patch · 19 files changed

+7217/−391 lines, 19 filesdep +exceptionsdep ~clash-libdep ~clash-preludedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions

Dependency ranges changed: clash-lib, clash-prelude, ghc, ghc-boot, ghc-prim, ghci, template-haskell

API changes (from Hackage documentation)

+ Clash.GHC.Evaluator: isUndefinedPrimVal :: Value -> Bool
+ Clash.GHCi.Common: getMainTopEntity :: HasCallStack => String -> BindingMap -> [TopEntityT] -> String -> IO (TopEntityT, [TopEntityT])

Files

CHANGELOG.md view
@@ -1,9 +1,36 @@ # Changelog for the Clash project +## 1.2.2 *June 12th 2020*+++* Changed:+  * The hardwired functions to unroll primitive definitions for 'zipWith', 'map', 'foldr', and 'init' have been changed to only unroll a single step, whereas they would previously unroll the whole definition in one step. This allows Clash to take advantage of the lazy nature of these functions, in turn speeding up compilation speeds significantly in some cases. Part of [PR 1354](https://github.com/clash-lang/clash-compiler/pull/1354).++* Added:+  * Support for GHC 8.10+  * Ability to load designs from precompiled modules (i.e., stored in a package database). See [#1172](https://github.com/clash-lang/clash-compiler/pull/1172)+  * Support for '-main-is' when used with `--vhdl`, `--verilog`, or `--systemverilog`+  * A partial instance for `NFDataX (Signal domain a)`++* Fixed:+  * Clash's evaluator now inlines work free definitions, preventing [situations where it would otherwise get stuck in an infinite loop](https://github.com/clash-lang/clash-compiler/pull/1354#issuecomment-635430374)+  * `caseCon` doesn't apply type-substitution correctly [#1340](https://github.com/clash-lang/clash-compiler/issues/1340)+  * Clash generates illegal SystemVerilog slice [#1313](https://github.com/clash-lang/clash-compiler/issues/1313)+  * Fix result type of head and tail Verilog blackboxes [#1351](https://github.com/clash-lang/clash-compiler/issues/1351)+  * Certain recursive let-expressions in side a alternatives of a case-expression throw the Clash compiler into an infinite loop [#1316](https://github.com/clash-lang/clash-compiler/issues/1316)+  * Fixes issue with one of Clash's transformations, `inlineCleanup`, introducing free variables [#1337](https://github.com/clash-lang/clash-compiler/issues/1337)+  * Fails to propagate type information of existential type [#1310](https://github.com/clash-lang/clash-compiler/issues/1310)+  * Certain case-expressions throw the Clash compiler into an infinite loop [#1320](https://github.com/clash-lang/clash-compiler/issues/1320)+  * Added blackbox implementation for 'Clash.Sized.Vector.iterateI', hence making it usable as a register reset value [#1240](https://github.com/clash-lang/clash-compiler/issues/1240)+  * `iterate` and `iterateI` can now be used in reset values [#1240](https://github.com/clash-lang/clash-compiler/issues/1240)+  * Prim evaluation fails on undefined arguments [#1297](https://github.com/clash-lang/clash-compiler/issues/1297)+  * Missing re-indexing in (Un)Signed fromSLV conversion [#1292](https://github.com/clash-lang/clash-compiler/issues/1292)+  * VHDL: generate a type qualification inside ~TOBV, fixes [#1360](https://github.com/clash-lang/clash-compiler/issues/1360)+ ## 1.2.1 *April 23rd 2020* * Changed:- * Treat `Signed 0`, `Unsigned 0`, `Index 1`, `BitVector 0` as unit. In effect this means that 'minBound' and 'maxBound' return 0, whereas previously they might crash [#1183](https://github.com/clash-lang/clash-compiler/issues/1183)- * Infix use of `deepseqX` is now right-associative+  * Treat `Signed 0`, `Unsigned 0`, `Index 1`, `BitVector 0` as unit. In effect this means that 'minBound' and 'maxBound' return 0, whereas previously they might crash [#1183](https://github.com/clash-lang/clash-compiler/issues/1183)+  * Infix use of `deepseqX` is now right-associative  * Added:   * Add 'natToInteger', 'natToNatural', and 'natToNum'. Similar to 'snatTo*', but works solely on a type argument instead of an SNat.@@ -11,12 +38,12 @@   * Added NFDataX instances for `Data.Monoid.{First,Last}`  * Fixed:- * The Verilog backend can now deal with non-contiguous ranges in custom bit-representations.- * Synthesizing BitPack instances for type with phantom parameter fails [#1242](https://github.com/clash-lang/clash-compiler/issues/1242)- * Synthesis of `fromBNat (toBNat d5)` failed due to `unsafeCoerce` coercing from `Any`- * Memory leak in register primitives [#1256](https://github.com/clash-lang/clash-compiler/issues/1256)- * Illegal VHDL slice when projecting nested SOP type [#1254](https://github.com/clash-lang/clash-compiler/issues/1254)- * Vivado VHDL code path (`-fclash-hdlsyn Vivado`) generates illegal VHDL [#1264](https://github.com/clash-lang/clash-compiler/issues/1264)+  * The Verilog backend can now deal with non-contiguous ranges in custom bit-representations.+  * Synthesizing BitPack instances for type with phantom parameter fails [#1242](https://github.com/clash-lang/clash-compiler/issues/1242)+  * Synthesis of `fromBNat (toBNat d5)` failed due to `unsafeCoerce` coercing from `Any`+  * Memory leak in register primitives [#1256](https://github.com/clash-lang/clash-compiler/issues/1256)+  * Illegal VHDL slice when projecting nested SOP type [#1254](https://github.com/clash-lang/clash-compiler/issues/1254)+  * Vivado VHDL code path (`-fclash-hdlsyn Vivado`) generates illegal VHDL [#1264](https://github.com/clash-lang/clash-compiler/issues/1264)  ## 1.2.0 *March 5th 2020* As promised when releasing 1.0, we've tried our best to keep the API stable. We
clash-ghc.cabal view
@@ -1,6 +1,6 @@ Cabal-version:        2.2 Name:                 clash-ghc-Version:              1.2.1+Version:              1.2.2 Synopsis:             CAES Language for Synchronous Hardware Description:   Clash is a functional hardware description language that borrows both its@@ -112,7 +112,9 @@ library   import:             common-options   HS-Source-Dirs:     src-ghc, src-bin-common-  if impl(ghc >= 8.7.0)+  if impl(ghc >= 8.10.0)+    HS-Source-Dirs: src-bin-8.10+  elif impl(ghc >= 8.8.0)     HS-Source-Dirs: src-bin-881   elif impl(ghc >= 8.6.0)     HS-Source-Dirs: src-bin-861@@ -120,7 +122,10 @@     HS-Source-Dirs: src-bin-841    GHC-Options:        -Wall -Wcompat-  CPP-Options:        -DGHCI+  if impl(ghc >= 8.10.0)+    CPP-Options:        -DHAVE_INTERNAL_INTERPRETER+  else+    CPP-Options:        -DGHCI    other-extensions:   FlexibleContexts                       OverloadedStrings@@ -134,7 +139,7 @@                       containers                >= 0.5.4.0  && < 0.7,                       directory                 >= 1.2      && < 1.4,                       filepath                  >= 1.3      && < 1.5,-                      ghc                       >= 8.4.0    && < 8.9,+                      ghc                       >= 8.4.0    && < 8.11,                       process                   >= 1.2      && < 1.7,                       hashable                  >= 1.1.2.3  && < 1.4,                       haskeline                 >= 0.7.0.3  && < 0.9,@@ -145,24 +150,27 @@                       transformers              >= 0.5.2.0  && < 0.6,                       unordered-containers      >= 0.2.1.0  && < 0.3, -                      clash-lib                 == 1.2.1,-                      clash-prelude             == 1.2.1,+                      clash-lib                 == 1.2.2,+                      clash-prelude             == 1.2.2,                       concurrent-supply         >= 0.1.7    && < 0.2,                       ghc-typelits-extra        >= 0.3.3    && < 0.5,                       ghc-typelits-knownnat     >= 0.7.2    && < 0.8,                       ghc-typelits-natnormalise >= 0.7.2    && < 0.8,                       deepseq                   >= 1.3.0.2  && < 1.5,                       time                      >= 1.4.0.1  && < 1.11,-                      ghc-boot                  >= 8.4.0    && < 8.9,-                      ghc-prim                  >= 0.3.1.0  && < 0.6,-                      ghci                      >= 8.4.0    && < 8.9,+                      ghc-boot                  >= 8.4.0    && < 8.11,+                      ghc-prim                  >= 0.3.1.0  && < 0.7,+                      ghci                      >= 8.4.0    && < 8.11,                       uniplate                  >= 1.6.12   && < 1.8,                       reflection                >= 2.1.2    && < 3.0,                       integer-gmp               >= 1.0.1.0  && < 2.0,                       primitive                 >= 0.5.0.1  && < 1.0,-                      template-haskell          >= 2.8.0.0  && < 2.16,+                      template-haskell          >= 2.8.0.0  && < 2.17,                       utf8-string               >= 1.0.0.0  && < 1.1.0.0,                       vector                    >= 0.11     && < 1.0+  if impl(ghc >= 8.10.0)+    Build-Depends:    exceptions                >= 0.10.4   && < 0.11,+   if flag(use-ghc-paths)     Build-Depends:    ghc-paths     CPP-Options:      -DUSE_GHC_PATHS=1
+ src-bin-8.10/Clash/GHCi/Leak.hs view
@@ -0,0 +1,74 @@+{-# 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 HscTypes+import Outputable+import GHC.Platform (target32Bit)+import Prelude+import System.Mem+import System.Mem.Weak+import UniqDFM++-- 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 HscEnv{..} =+  fmap LeakIndicators $+    forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do+      leakMod <- mkWeakPtr hmi Nothing+      leakIface <- mkWeakPtr hm_iface Nothing+      leakDetails <- mkWeakPtr hm_details Nothing+      leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable+      return $ LeakModIndicators{..}++-- | 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 >>= report "ModIface"+    deRefWeak leakDetails >>= report "ModDetails"+    forM_ leakLinkable $ \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-8.10/Clash/GHCi/UI.hs view
@@ -0,0 +1,4290 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI (+        interactiveUI,+        GhciSettings(..),+        defaultGhciSettings,+        ghciCommands,+        ghciWelcomeMsg,+        makeHDL+    ) where++#include "HsVersions.h"++-- GHCi+import qualified Clash.GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )+import Clash.GHCi.UI.Monad hiding ( args, runStmt )+import Clash.GHCi.UI.Tags+import Clash.GHCi.UI.Info+import Debugger++-- The GHC interface+import GHCi+import GHCi.RemoteTypes+import GHCi.BreakArray+import DynFlags+import ErrUtils hiding (traceCmd)+import Finder+import GhcMonad ( modifySession )+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),+             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,+             GetDocsFailure(..),+             getModuleGraph, handleSourceError )+import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation)+import GHC.Hs.ImpExp+import GHC.Hs+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+                  setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,+                  hsc_dynLinker )+import Module+import Name+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,+                  listVisibleModuleNames, pprFlag )+import IfaceSyn ( showToHeader )+import PprTyThing+import PrelNames+import RdrName ( getGRE_NameQualifier_maybes, getRdrName )+import SrcLoc+import qualified Lexer++import StringBuffer+import Outputable hiding ( printForUser, printForUserPartWay )++import DynamicLoading ( initializePlugins )++-- Other random utilities+import BasicTypes hiding ( isTopLevel )+import Digraph+import Encoding+import FastString+import Linker+import Maybes ( orElse, expectJust )+import NameSet+import Panic hiding ( showException )+import Util+import qualified GHC.LanguageExtensions as LangExt+import Bag (unitBag)++-- 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.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 ( find, group, intercalate, intersperse, isPrefixOf,+                   isSuffixOf, nub, partition, sort, sortBy, (\\) )+import qualified Data.Set as S+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as M+import qualified Data.IntMap.Strict as IntMap+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )+import Prelude hiding ((<>))++import Exception hiding (catch)+import Foreign hiding (void)+import GHC.Stack hiding (SrcLoc(..))++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++-- clash additions+import qualified Clash.Backend+import           Clash.Backend.SystemVerilog (SystemVerilogState)+import           Clash.Backend.VHDL (VHDLState)+import           Clash.Backend.Verilog (VerilogState)+import qualified Clash.Driver+import           Clash.Driver.Types (ClashOpts(..))+import           Clash.GHC.Evaluator+import           Clash.GHC.GenerateBindings+import           Clash.GHC.NetlistTypes+import           Clash.GHCi.Common+import           Clash.Netlist.BlackBox.Types (HdlSyn)+import           Clash.Util (clashLibVersion, reportTimeDiff)+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++import           Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)++-----------------------------------------------------------------------------++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,             completeIdentifier),+  ("back",      keepGoing backCmd,              noCompletion),+  ("browse",    keepGoing' (browseCmd False),   completeModule),+  ("browse!",   keepGoing' (browseCmd True),    completeModule),+  ("cd",        keepGoing' changeDirectory,     completeFilename),+  ("check",     keepGoing' checkModule,         completeHomeModule),+  ("continue",  keepGoing continueCmd,          noCompletion),+  ("cmd",       keepGoing cmdCmd,               completeExpression),+  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),+  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),+  ("def",       keepGoing (defineMacro False),  completeExpression),+  ("def!",      keepGoing (defineMacro True),   completeExpression),+  ("delete",    keepGoing deleteCmd,            noCompletion),+  ("disable",   keepGoing disableCmd,           noCompletion),+  ("doc",       keepGoing' docCmd,              completeIdentifier),+  ("edit",      keepGoing' editFile,            completeFilename),+  ("enable",    keepGoing enableCmd,            noCompletion),+  ("etags",     keepGoing createETagsFileCmd,   completeFilename),+  ("force",     keepGoing forceCmd,             completeExpression),+  ("forward",   keepGoing forwardCmd,           noCompletion),+  ("help",      keepGoing help,                 noCompletion),+  ("history",   keepGoing historyCmd,           noCompletion),+  ("info",      keepGoing' (info False),        completeIdentifier),+  ("info!",     keepGoing' (info True),         completeIdentifier),+  ("issafe",    keepGoing' isSafeCmd,           completeModule),+  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),+  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),+  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),+  ("load!",     keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),+  ("list",      keepGoing' listCmd,             noCompletion),+  ("module",    keepGoing moduleCmd,            completeSetModule),+  ("main",      keepGoing runMain,              completeFilename),+  ("print",     keepGoing printCmd,             completeExpression),+  ("quit",      quit,                           noCompletion),+  ("reload",    keepGoing' reloadModule,        noCompletion),+  ("reload!",   keepGoing' reloadModuleDefer,   noCompletion),+  ("run",       keepGoing runRun,               completeFilename),+  ("script",    keepGoing' scriptCmd,           completeFilename),+  ("set",       keepGoing setCmd,               completeSetOptions),+  ("seti",      keepGoing setiCmd,              completeSeti),+  ("show",      keepGoing showCmd,              completeShowOptions),+  ("showi",     keepGoing showiCmd,             completeShowiOptions),+  ("sprint",    keepGoing sprintCmd,            completeExpression),+  ("step",      keepGoing stepCmd,              completeIdentifier),+  ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),+  ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),+  ("type",      keepGoing' typeOfExpr,          completeExpression),+  ("trace",     keepGoing traceCmd,             completeExpression),+  ("unadd",     keepGoingPaths unAddModule,     completeFilename),+  ("undef",     keepGoing undefineMacro,        completeMacro),+  ("unset",     keepGoing unsetOptions,         completeSetOptions),+  ("where",     keepGoing whereCmd,             noCompletion),+  ("vhdl",      keepGoingPaths (makeVHDL opts),        completeHomeModuleOrFile),+  ("verilog",   keepGoingPaths (makeVerilog opts),     completeHomeModuleOrFile),+  ("systemverilog",   keepGoingPaths (makeSystemVerilog opts),     completeHomeModuleOrFile),+  ("instances", keepGoing' instancesCmd,        completeExpression)+  ] ++ map mkCmdHidden [ -- hidden commands+  ("all-types", keepGoing' allTypesCmd),+  ("complete",  keepGoing completeCmd),+  ("loc-at",    keepGoing' locAtCmd),+  ("type-at",   keepGoing' typeAtCmd),+  ("uses",      keepGoing' usesCmd)+  ]+ where+  mkCmd (n,a,c) = Command { cmdName = n+                          , cmdAction = a+                          , cmdHidden = False+                          , cmdCompletionFunc = c+                          }++  mkCmdHidden (n,a) = Command { cmdName = n+                              , cmdAction = a+                              , cmdHidden = True+                              , cmdCompletionFunc = noCompletion+                              }++-- We initialize readline (in the interactiveUI function) to use+-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+--+-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = spaces ++ specials ++ symbols++symbols, specials, spaces :: String+symbols = "!#$%&*+/<=>?@\\^|-~"+specials = "(),;[]`{}"+spaces = " \t\n"++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool+keepGoing' a str = a str >> return False++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)+keepGoingPaths a str+ = do case toArgs str of+          Left err -> liftIO $ hPutStrLn stderr err+          Right args -> a args+      return False++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" +++  "   :ctags[!] [<file>]          create tags file <file> for Vi (default: \"tags\")\n" +++  "                               (!: use regex instead of line number)\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" +++  "   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\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" +++  "   :type +v <expr>             show the type of <expr>, with its specified tyvars\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                   resume after a breakpoint\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" +++  "   :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 .clashi in current dir\n" +++  "                               (loading untrusted config is a security issue)\n" +++  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" +++  "   :set prog <progname>        set the value returned by System.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"++findEditor :: IO String+findEditor = do+  getEnv "EDITOR"+    `catchIO` \_ -> 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 "%s> "+default_prompt_cont = generatePromptFunctionFromString "%s| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+              -> Ghc ()+interactiveUI config srcs maybe_exprs = do+   -- HACK! If we happen to get into an infinite loop (eg the user+   -- types 'let x=x in x' at the prompt), then the thread will block+   -- on a blackhole, and become unreachable during GC.  The GC will+   -- detect that it is unreachable and send it the NonTermination+   -- exception.  However, since the thread is unreachable, everything+   -- it refers to might be finalized, including the standard Handles.+   -- This sounds like a bug, but we don't have a good solution right+   -- now.+   _ <- liftIO $ newStablePtr stdin+   _ <- liftIO $ newStablePtr stdout+   _ <- liftIO $ newStablePtr stderr++    -- Initialise buffering for the *interpreted* I/O system+   (nobuffering, flush) <- 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'++   lastErrLocationsRef <- liftIO $ newIORef []+   progDynFlags <- GHC.getProgramDynFlags+   _ <- GHC.setProgramDynFlags $+      -- Ensure we don't override the user's log action lest we break+      -- -ddump-json (#14078)+      progDynFlags { log_action = ghciLogAction (log_action progDynFlags)+                                                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 = simpleImportDecl preludeModuleName+   startGHCi (runGHCi srcs maybe_exprs)+        GHCiState{ progname           = default_progname,+                   args               = default_args,+                   evalWrapper        = eval_wrapper,+                   prompt             = defPrompt config,+                   prompt_cont        = defPromptCont config,+                   stop               = default_stop,+                   editor             = default_editor,+                   options            = [],+                   localConfig        = SourceLocalConfig,+                   -- We initialize line number as 0, not 1, because we use+                   -- current line number while reporting errors which is+                   -- incremented after reading a line.+                   line_number        = 0,+                   break_ctr          = 0,+                   breaks             = IntMap.empty,+                   tickarrays         = emptyModuleEnv,+                   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+                 }++   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 :: LogAction -> IORef [(FastString, Int)] ->  LogAction+ghciLogAction old_log_action lastErrLocations+              dflags flag severity srcSpan style msg = do+    old_log_action dflags flag severity srcSpan style msg+    case severity of+        SevError -> case srcSpan of+            RealSrcSpan rsp -> modifyIORef lastErrLocations+                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+            _ -> return ()+        _ -> return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+    either_dir <- tryIO (getAppUserDataDirectory "clash")+    case either_dir of+        Right dir ->+            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+               right dir+        _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+  dflags <- getDynFlags+  let+   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++   app_user_dir = liftIO $ withGhcAppData+                    (\dir -> return (Just (dir </> "clashi.conf")))+                    (return Nothing)++   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 .clashi+        -- (but not $CWD/.clashi or CLI args, yet)++      behaviour <- localConfig <$> getGHCiState++      processedLocalCfg <- case localCfg of+        Just path | path `notElem` userCfgs ->+          -- don't read .clashi 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/.clashi was ignored due to configuration,+    -- explicitly specifying it does cause it to be processed.++  -- Perform a :load for files given on the GHCi command line+  -- 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) $+                -- TODO: this is a hack.+                runInputTWithPrefs defaultPrefs defaultSettings $+                    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 invalid input, see #7962+        _ <- 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 $ withGhcAppData+        (\dir -> return (Just (dir </> "clashi_history"))) (return Nothing)+      _ -> 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 .clashi 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 ./.clashi 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 .clashi 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)++parseCallEscape :: String -> (String, String)+parseCallEscape s+  | not (all isSpace beforeOpen) = ("", "")+  | null sinceOpen               = ("", "")+  | null sinceClosed             = ("", "")+  | null cmd                     = ("", "")+  | otherwise                    = (cmd, tail sinceClosed)+  where+    (beforeOpen, sinceOpen) = span (/='(') s+    (cmd, sinceClosed) = span (/=')') (tail sinceOpen)++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+  case parseCallEscape xs of+    ("", "") -> Just ("Incorrect %call syntax. " +++                      "Should be %call(a command and arguments).")+    (_, 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 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+            respond <- liftIO $ do+                (code, out, err) <-+                    readProcessWithExitCode+                    (head list_words) (tail list_words) ""+                    `catchIO` \e -> return (ExitFailure 1, "", show e)+                case code of+                    ExitSuccess -> return out+                    _ -> do+                        hPutStrLn stderr err+                        return ""+            liftM ((text respond) <>) (processString afterClosed)+            where+              (cmd, afterClosed) = parseCallEscape xs+              list_words = words cmd+        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 :: GHC.GhcMonad m => Maybe String -> Bool -> m ()+installInteractivePrint Nothing _  = return ()+installInteractivePrint (Just ipFun) exprmode = do+  ok <- trySuccess $ do+                names <- GHC.parseName ipFun+                let name = case names of+                             name':_ -> name'+                             [] -> panic "installInteractivePrint"+                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 (Maybe Bool)+         -- We want to return () here, but have to return (Maybe Bool)+         -- because gmask is not polymorphic enough: we want to use+         -- unmask at two different types.+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do+    b <- ghandle (\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 Nothing+      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.+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+        GHC.printException 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 "" `GHC.gfinally`+                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 :{ .. :}"++    -- | 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+      let processResult True = Nothing+          processResult False = Just True+      return $ CommandComplete stmt' (processResult <$> 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.mkPState dflags buf' loc+   case Lexer.unP goToEnd pstate of+     (Lexer.POk _ False) -> return $ Just stmt+     _other              -> do+       st1 <- getGHCiState+       let p = prompt st1+       setGHCiState st1{ prompt = prompt_cont st1 }+       mb_stmt <- ghciHandle (\ex -> case fromException ex of+                            Just UserInterrupt -> return Nothing+                            _ -> case fromException ex of+                                 Just ghce ->+                                   do liftIO (print (ghce :: GhcException))+                                      return Nothing+                                 _other -> liftIO (Exception.throwIO ex))+                     getStmt+       modifyGHCiState (\st' -> st' { prompt = p })+       -- the recursive call does not recycle parser state+       -- as we use a new string buffer+       case mb_stmt of+         Nothing  -> return Nothing+         Just str -> if str == ""+           then return $ Just stmt+           else do+             checkInputForLayout (stmt++"\n"++str) getStmt+     where goToEnd = do+             eof <- Lexer.nextIsEOF+             if eof+               then Lexer.activeContext+               else Lexer.lexer False return >> goToEnd++enqueueCommands :: GhciMonad m => [String] -> m ()+enqueueCommands cmds = do+  -- make sure we force any exceptions in the commands while we're+  -- still inside the exception handler, otherwise bad things will+  -- happen (see #10501)+  cmds `deepseq` return ()+  modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`.+runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)+runStmt input step = do+  dflags <- GHC.getInteractiveDynFlags+  -- 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 typecheck/TcRnDriver.hs+  st <- getGHCiState+  let source = progname st+  let line = line_number st++  if | GHC.isStmt dflags 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++     | GHC.isImport dflags input -> run_import++     -- Every import declaration should be handled by `run_import`. As GHCi+     -- in general only accepts one command at a time, we simply throw an+     -- exception when the input contains multiple commands of which at least+     -- one is an import command (see #10663).+     | GHC.hasImport dflags input -> throwGhcException+       (CmdLineError "error: expecting a single import declaration")++     -- Otherwise assume a declaration (or a list of declarations)+     -- 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+         decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)+         run_decls decls+  where+    exec_complete = GHC.ExecComplete (Right []) 0++    run_import = do+      addImportToContext input+      return (Just exec_complete)++    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 l bind)+    run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt 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 l = L loc+      in l (LetStmt noExtField (l (HsValBinds noExtField (ValBinds noExtField (unitBag (l bind)) []))))++-- | 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+         | isNothing  mb_info ||+           step_here (GHC.resumeSpan $ head resumes) -> do+               mb_id_loc <- toBreakIdAndLocation mb_info+               let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+               if (null bCmd)+                 then printStoppedAtBreakInfo (head resumes) names+                 else enqueueCommands [bCmd]+               -- run the command set with ":set stop <cmd>"+               st <- getGHCiState+               enqueueCommands [stop st]+               return ()+         | otherwise -> resume step_here GHC.SingleStep >>=+                        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+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+    where compareWith n = (getOccString n, getSrcSpan n)++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 Bool+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 stdout ("unknown command ':" ++ cmd ++ "'\n"+                           ++ htxt)+         return False+    NoLastCommand ->+      do liftIO $ hPutStr stdout ("there is no last command to perform\n"+                           ++ htxt)+         return False++shellEscape :: MonadIO m => String -> m Bool+shellEscape str = liftIO (system str >> return False)++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+       hsc_env <- GHC.getSession+       Just <$> liftIO (costCentreStackInfo hsc_env (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 <+>+                         ptext (sLit "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 GHC.printException $ do+    unqual <- GHC.getPrintUnqual+    dflags <- getDynFlags+    sdocs  <- mapM (infoThing allInfo) (words s)+    mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++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 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+  $$ show_fixity+  $$ vcat (map GHC.pprInstance cls_insts)+  $$ vcat (map GHC.pprFamInst  fam_insts)+  where+    show_fixity+        | fixity == GHC.defaultFixity = empty+        | otherwise                   = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: GhciMonad m => String -> m ()+runMain s = case toArgs s of+            Left err   -> liftIO (hPutStrLn stderr err)+            Right args ->+                do dflags <- getDynFlags+                   let main = fromMaybe "main" (mainFunIs dflags)+                   -- Wrap the main function in 'void' to discard its value instead+                   -- of printing it (#9086). See Haskell 2010 report Chapter 5.+                   doWithArgs args $ "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 ++ ")"]++-----------------------------------------------------------------------------+-- :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 targets and all eventually defined breakpoints (#1620)+  clearAllTargets+  setContextAfterLoad False []+  GHC.workingDirectoryChanged+  dir' <- expandPath dir+  liftIO $ setCurrentDirectory dir'+  dflags <- getDynFlags+  -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+  -- (this gives consistent behaviour with and without -fexternal-interpreter)+  when (gopt Opt_ExternalInterpreter dflags) $ do+    hsc_env <- GHC.getSession+    fhv <- compileGHCiExpr $+      "System.Directory.setCurrentDirectory " ++ show dir'+    liftIO $ evalIO hsc_env fhv++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+    handleSourceError (\e -> do GHC.printException e+                                return Failed) $ do+      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 depndecy 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 occured 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 x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++     graph <- GHC.getModuleGraph+     failed_graph <-+       GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)+     let order g  = flattenSCCs $ 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 (GHC.TargetFile f _) _ _) = Just f+        fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()+defineMacro _ (':':_) = liftIO $ putStrLn+                          "macro name cannot start with a colon"+defineMacro _ ('!':_) = liftIO $ putStrLn+                          "macro name cannot start with an exclamation mark"+                          -- 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 GHC.printException $ do+      step <- getGhciStepIO+      expr <- GHC.parseExpr definition+      -- > ghciStepIO . definition :: String -> IO String+      let stringTy = nlHsTyVar stringTy_RDR+          ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+          body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+                                     `mkHsApp` (nlHsPar expr)+          tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)+          new_expr = L (getLoc expr) $ ExprWithTySig noExtField 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 Bool+runMacro fun s = do+  hsc_env <- GHC.getSession+  str <- liftIO $ evalStringToIOString hsc_env fun s+  enqueueCommands (lines str)+  return False+++-----------------------------------------------------------------------------+-- :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 GHC.printException $ do+    step <- getGhciStepIO+    expr <- GHC.parseExpr str+    -- > ghciStepIO str :: IO String+    let new_expr = step `mkHsApp` expr+    hv <- GHC.compileParsedExprRemote new_expr++    hsc_env <- GHC.getSession+    cmds <- liftIO $ evalString hsc_env 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 stringTy_RDR+      ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy+      ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+      body = nlHsVar (getRdrName ghciStepIoMName)+      tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)+  return $ noLoc $ ExprWithTySig noExtField body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: GhciMonad m => String -> m ()+checkModule m = do+  let modl = GHC.mkModuleName m+  ok <- handleSourceError (\e -> GHC.printException 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) False++-----------------------------------------------------------------------------+-- :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+  e_docss <- mapM GHC.getDocs names+  sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss+  let sdocs' = vcat (intersperse (text "") sdocs)+  unqual <- GHC.getPrintUnqual+  dflags <- getDynFlags+  (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'++-- TODO: also print arg docs.+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc+pprDocs (mb_decl_docs, _arg_docs) =+  maybe+    (text "<has no documentation>")+    (text . unpackHDS)+    mb_decl_docs++handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc+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 GHC.printException $ do+    ty <- GHC.parseInstanceHead s+    res <- GHC.getInstancesForType ty++    printForUser $ vcat $ map ppr res++-----------------------------------------------------------------------------+-- :load, :add, :reload++-- | 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 =+  gbracket+    (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 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 (zip fs (repeat Nothing))++loadModuleDefer :: GhciMonad m => [FilePath] -> m ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag+loadModule' files = do+  let (filenames, phases) = unzip files+  exp_filenames <- mapM expandPath filenames+  let files' = zip exp_filenames phases+  targets <- mapM (uncurry GHC.guessTarget) 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++  -- Grab references to the currently loaded modules so that we can+  -- see if they leak.+  let !dflags = hsc_dflags hsc_env+  leak_indicators <- if gopt Opt_GhciLeakCheck dflags+    then liftIO $ getLeakIndicators hsc_env+    else return (panic "no leak indicators")++  -- unload first+  _ <- GHC.abandonAll+  clearAllTargets++  GHC.setTargets targets+  success <- doLoadAndCollectInfo False LoadAllTargets+  when (gopt Opt_GhciLeakCheck dflags) $+    liftIO $ checkLeakIndicators dflags leak_indicators+  return success++-- | @: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) files'+  targets' <- filterM checkTarget targets+  -- remove old targets with the same id; e.g. for :add *M+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]+  mapM_ GHC.addTarget targets'+  _ <- doLoadAndCollectInfo False LoadAllTargets+  return ()+  where+    checkTarget :: GHC.GhcMonad m => Target -> m Bool+    checkTarget (Target (TargetModule m) _ _) = checkTargetModule m+    checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f++    checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool+    checkTargetModule m = do+      hsc_env <- GHC.getSession+      result <- liftIO $+        Finder.findImportedModule hsc_env m (Just (fsLit "this"))+      case result of+        Found _ _ -> return True+        _ -> (liftIO $ putStrLn $+          "Module " ++ moduleNameString m ++ " not found") >> return False++    checkTargetFile :: String -> IO Bool+    checkTargetFile f = do+      exists <- (doesFileExist f) :: IO Bool+      unless exists $ putStrLn $ "File " ++ f ++ " not found"+      return exists++-- | @:unadd@ command+unAddModule :: GhciMonad m => [FilePath] -> m ()+unAddModule files = do+  files' <- mapM expandPath files+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+  _ <- doLoadAndCollectInfo False LoadAllTargets+  return ()++-- | @:reload@ command+reloadModule :: GhciMonad m => String -> m ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+  where+    loadTargets | null m    = LoadAllTargets+                | otherwise = LoadUpTo (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 => Bool -> LoadHowMuch -> m SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+  doCollectInfo <- isOptionSet CollectInfo++  doLoad retain_context howmuch >>= \case+    Succeeded | doCollectInfo -> do+      mod_summaries <- GHC.mgModSummaries <$> getModuleGraph+      loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries+      v <- mod_infos <$> getGHCiState+      !newInfos <- collectInfo v loaded+      modifyGHCiState (\st -> st { mod_infos = newInfos })+      return Succeeded+    flag -> return flag++doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag+doLoad retain_context 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.+  gbracket (liftIO $ do hSetBuffering stdout LineBuffering+                        hSetBuffering stderr LineBuffering)+           (\_ ->+            liftIO $ do hSetBuffering stdout NoBuffering+                        hSetBuffering stderr NoBuffering) $ \_ -> do+      ok <- trySuccess $ GHC.load howmuch+      afterLoad ok retain_context+      return ok+++afterLoad+  :: GhciMonad m+  => SuccessFlag+  -> Bool   -- keep the remembered_ctx, as far as possible (:reload)+  -> m ()+afterLoad ok retain_context = do+  revertCAFs  -- always revert CAFs on load.+  discardTickArrays+  loaded_mods <- getLoadedModules+  modulesLoadedMsg ok loaded_mods+  setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()+setContextAfterLoad keep_ctxt [] = do+  setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+  -- load a target if one is available, otherwise load the topmost module.+  targets <- GHC.getTargets+  case [ m | Just m <- map (findTarget ms) targets ] of+        []    ->+          let graph = GHC.mkModuleGraph ms+              graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)+          in load_this (last graph')+        (m:_) ->+          load_this m+ where+   findTarget mds t+    = case filter (`matches` t) mds of+        []    -> Nothing+        (m:_) -> Just m++   summary `matches` Target (TargetModule m) _ _+        = GHC.ms_mod_name summary == m+   summary `matches` Target (TargetFile f _) _ _+        | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'+   _ `matches` _+        = False++   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 e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)+              case e :: Either SomeException Module of+                Left _  -> return False+                Right m -> return (not (isHomeModule m))+        where+          mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()+modulesLoadedMsg ok mods = do+  dflags <- getDynFlags+  unqual <- GHC.getPrintUnqual++  msg <- if gopt Opt_ShowLoadedModules dflags+         then do+               mod_names <- mapM mod_name mods+               let mod_commas+                     | null mods = text "none."+                     | otherwise = hsep (punctuate comma mod_names) <> text "."+               return $ status <> text ", modules loaded:" <+> mod_commas+         else do+               return $ status <> text ","+                    <+> speakNOf (length mods) (text "module") <+> "loaded."++  when (verbosity dflags > 0) $+     liftIO $ putStrLn $ showSDocForUser dflags unqual msg+  where+    status = case ok of+                  Failed    -> text "Failed"+                  Succeeded -> text "Ok"++    mod_name mod = do+        is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod+        return $ 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'+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()+runExceptGhcMonad act = handleSourceError GHC.printException $+                        either handleErr pure =<<+                        runExceptT act+  where+    handleErr sdoc = do+        dflags <- getDynFlags+        liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc++-- | 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' :: Clash.Backend.Backend backend+         => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+         -> IORef ClashOpts+         -> [FilePath]+         -> InputT GHCi ()+makeHDL' backend opts lst = go =<< case lst of+  srcs@(_:_) -> return srcs+  []         -> do+    modGraph <- GHC.getModuleGraph+    let sortedGraph = 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 `gfinally` 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 (unload env [])+    -- Finally generate the HDL+    makeHDL backend opts srcs++  recover dflags = do+    _ <- GHC.setSessionDynFlags dflags+    reloadModule ""++makeHDL :: GHC.GhcMonad m+        => Clash.Backend.Backend backend+        => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)+        -> IORef ClashOpts+        -> [FilePath]+        -> m ()+makeHDL backend optsRef srcs = do+  dflags <- GHC.getSessionDynFlags+  liftIO $ do startTime <- Clock.getCurrentTime+              opts0  <- readIORef optsRef+              let opts1  = opts0 { opt_color = useColor dflags }+              let iw     = opt_intWidth opts1+                  fp     = opt_floatSupport opts1+                  syn    = opt_hdlSyn opts1+                  color  = opt_color opts1+                  esc    = opt_escapedIds opts1+                  frcUdf = opt_forceUndefined opts1+                  hdl    = Clash.Backend.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' = backend iw syn esc frcUdf++              checkMonoLocalBinds dflags+              checkImportDirs opts0 idirs++              primDirs <- Clash.Backend.primDirs backend'++              forM_ srcs $ \src -> do+                -- Generate bindings:+                let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]+                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-+                  generateBindings color primDirs idirs dbs hdl src (Just dflags)+                let getMain = getMainTopEntity src bindingsMap topEntities+                mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)+                prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+                let prepStartDiff = reportTimeDiff prepTime startTime+                putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff++                -- Generate HDL:+                Clash.Driver.generateHDL+                  (buildCustomReprs reprs)+                  bindingsMap+                  (Just backend')+                  primMap+                  tcm+                  tupTcm+                  (ghcTypeToHWType iw fp)+                  primEvaluator+                  topEntities+                  mainTopEntity+                  opts2+                  (startTime,prepTime)++makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)++makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: GHC.GhcMonad m => String -> m ()+typeOfExpr str = handleSourceError GHC.printException $ do+    let (mode, expr_str) = case break isSpace str of+          ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)+          ("+v", rest) -> (GHC.TM_NoInst,  dropWhile isSpace rest)+          _            -> (GHC.TM_Inst,    str)+    ty <- GHC.exprType mode expr_str+    printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: GhciMonad m => String -> m ()+typeAtCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos      <- lift $ mod_infos <$> getGHCiState+    (info, ty) <- findType infos span' sample+    lift $ printForUserModInfo (modinfoInfo info)+                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: GhciMonad m => String -> m ()+usesCmd str = runExceptGhcMonad $ 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 = runExceptGhcMonad $ 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 _ = runExceptGhcMonad $ do+    infos <- lift $ mod_infos <$> getGHCiState+    forM_ (M.elems infos) $ \mi ->+        forM_ (modinfoSpans mi) (lift . printSpan)+  where+    printSpan span'+      | Just ty <- spaninfoType span' = do+        df <- getDynFlags+        let tyInfo = unwords . words $+                     showSDocForUser df alwaysQualify (pprTypeForUser 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 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 :: GHC.GhcMonad m => Bool -> String -> m ()+kindOfType norm str = handleSourceError GHC.printException $ do+    (ty, kind) <- GHC.typeKind norm str+    printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+                        , ppWhen norm $ equals <+> pprTypeForUser ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: Monad m => String -> m Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :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>")++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+    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  = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+        pkg    = if packageTrusted dflags m then "trusted" else "untrusted"+        (good, bad) = tallyPkgs dflags 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 dflags md+        | thisPackage dflags == moduleUnitId md = True+        | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)++    tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)+                          | otherwise = S.partition part deps+        where part pkg = trusted $ getInstalledPackageDetails dflags pkg++-----------------------------------------------------------------------------+-- :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+       when (null imports) $ throwGhcException $+          CmdLineError (':' : cmd ++ ": no current module")+       case (head imports) of+          IIModule m -> GHC.findModule m Nothing+          IIDecl d   -> GHC.findModule (unLoc (ideclName d))+                                       (fmap sl_fs $ ideclPkgQual 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+  -- :browse reports qualifiers wrt current context+  unqual <- GHC.getPrintUnqual++  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+        dflags <- getDynFlags+        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 (compare `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.. (trac #1799)+            annotate mts = concatMap (\(m,ts)->labels m:ts)+                         $ sortBy cmpQualifiers $ grp mts+              where cmpQualifiers =+                      compare `on` (map (fmap (map 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+        liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+        -- 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 => String -> m ()+addImportToContext str = restoreContextOnFailure $ do+  idecl <- GHC.parseImportDecl str+  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 `gonException` (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 = ideclPkgQual d+       m <- GHC.lookupModule modname (fmap sl_fs pkgqual)+       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))+     && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+  where+     _                    `hidingSubsumes` Just (False,L _ []) = True+     Just (False, L _ xs) `hidingSubsumes` Just (False,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 toArgs rest of+            Left err -> liftIO (hPutStrLn stderr err)+            Right args -> setArgs args+    Right ("prog",    rest) ->+        case toArgs 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 toArgs str of+         Left err -> liftIO (hPutStrLn stderr err)+         Right wds -> setOptions wds++setiCmd :: GhciMonad m => String -> m ()+setiCmd ""   = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str  =+  case toArgs 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)+           ))+       getDynFlags >>= liftIO . showDynFlags show_all+++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 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) (llvmConfig 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 :: GhciMonad m => Bool -> [String] -> m ()+newDynFlags interactive_only minus_opts = do+      let lopts = map noLoc minus_opts++      idflags0 <- GHC.getInteractiveDynFlags+      (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++      liftIO $ handleFlagWarnings idflags1 warns+      when (not $ null leftovers)+           (throwGhcException . CmdLineError+            $ "Some flags have not been recognized: "+            ++ (concat . intersperse ", " $ map unLoc leftovers))++      when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+          liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+      -- Load any new plugins+      hsc_env0 <- GHC.getSession+      idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)+      GHC.setInteractiveDynFlags idflags2+      installInteractivePrint (interactivePrint idflags1) False++      dflags0 <- getDynFlags++      when (not interactive_only) $ do+        (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+        new_pkgs <- 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+        when (packageFlagsChanged dflags2 dflags0) $ do+          when (verbosity dflags2 > 0) $+            liftIO . putStrLn $+              "package flags have changed, resetting and loading new packages..."+          -- delete targets and all eventually defined breakpoints. (#1620)+          clearAllTargets+          liftIO $ linkPackages hsc_env new_pkgs+          -- package flags changed, we can't re-use any of the old context+          setContextAfterLoad False []+          -- and copy the package state to the interactive DynFlags+          idflags <- GHC.getInteractiveDynFlags+          GHC.setInteractiveDynFlags+              idflags{ pkgState = pkgState dflags2+                     , pkgDatabase = pkgDatabase dflags2+                     , packageFlags = packageFlags dflags2 }++        let ld0length   = length $ ldInputs dflags0+            fmrk0length = length $ cmdlineFrameworks dflags0++            newLdInputs     = drop ld0length (ldInputs dflags2)+            newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++            hsc_env' = hsc_env { hsc_dflags =+                         dflags2 { ldInputs = newLdInputs+                                 , cmdlineFrameworks = newCLFrameworks } }++        when (not (null newLdInputs && null newCLFrameworks)) $+          liftIO $ linkCmdLineLibs hsc_env'++      return ()+++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 if (not (null rest3))+           then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+           else 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"     $ getDynFlags >>= liftIO . (showLinkerState (hsc_dynLinker hsc_env))+            , action "breaks"     $ showBkptTable+            , action "context"    $ showContext+            , action "packages"   $ showPackages+            , 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 (GHC.isLoaded . GHC.ms_mod_name) (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+        $$ show_fixity+      where+        show_fixity+            | fixity == GHC.defaultFixity  = empty+            | otherwise                    = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: GHC.GhcMonad m => TyThing -> m ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++{-+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.Types.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 compiler/main/InteractiveEval.hs++[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 =+        ptext (sLit "--> ") <> text (GHC.resumeStmt res)+        $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+  ptext (sLit "Stopped in")+    <+> ((case mb_mod_name of+           Nothing -> empty+           Just mod_name -> text (moduleNameString mod_name) <> char '.')+         <> text (GHC.resumeDecl res))+    <> char ',' <+> ppr (GHC.resumeSpan res)+ where+  mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showPackages :: GHC.GhcMonad m => m ()+showPackages = 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 language dflags of+           Nothing          -> text "Haskell2010"+           Just Haskell98   -> text "Haskell98"+           Just Haskell2010 -> text "Haskell2010"+     , (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) (llvmConfig dflags) `lang_set`+         case language dflags of+           Nothing -> Just Haskell2010+           other   -> other++showTargets :: GHC.GhcMonad m => m ()+showTargets = mapM_ showTarget =<< GHC.getTargets+  where+    showTarget :: GHC.GhcMonad m => Target -> m ()+    showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)+    showTarget (Target (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 argLine+        | null argLine = Nothing+        | null rest1   = Nothing+        | otherwise    = (,,) dom <$> resRange <*> s+      where+        (dom, rest1) = breakSpace argLine+        (rng, rest2) = breakSpace rest1+        resRange | head rest1 == '"' = parseRange ""+                 | otherwise         = parseRange rng+        s | head rest1 == '"' = readMaybe rest1 :: Maybe String+          | otherwise         = readMaybe rest2+        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+    :: 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+    (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line+    _                      -> wrapIdentCompleter complete line+  where+    complete w = do+      rdrs <- GHC.getRdrNamesInScope+      dflags <- GHC.getSessionDynFlags+      return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+  dflags <- GHC.getSessionDynFlags+  let pkg_mods = allVisibleModules dflags+  loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+  return $ filter (w `isPrefixOf`)+        $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+  dflags <- GHC.getSessionDynFlags+  modules <- case m of+    Just '-' -> do+      imports <- GHC.getContext+      return $ map iiModuleName imports+    _ -> do+      let pkg_mods = allVisibleModules dflags+      loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+      return $ loaded_mods ++ pkg_mods+  return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter 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 head $ group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+  return (filter (w `isPrefixOf`) flagList)+    where flagList = map head $ 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 fun = completeWord Nothing breakChars+    $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m+wrapIdentCompleter = wrapCompleter word_break_chars++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 :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames dflags++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+                        completeIdentifier+++-- -----------------------------------------------------------------------------+-- 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) 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+  ASSERT(inRange (bounds ticks) line) do+  let enclosing_spans = [ pan | (_,pan) <- ticks ! line+                               , realSrcSpanEnd pan >= realSrcSpanEnd src]+  return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan a b =+  (realSrcSpanStart a `compare` realSrcSpanStart b)+     `thenCmp`+  (realSrcSpanEnd b `compare` realSrcSpanEnd a)++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 ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()+doContinue pre step = do+  runResult <- resume pre step+  _ <- 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 <- getBreakLoc enaDisa strId+      case sdoc_loc of+        Left sdoc -> printForUser sdoc+        Right loc -> enaDisaAssoc enaDisa (read strId, loc)++getBreakLoc :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)+getBreakLoc enaDisa 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 ->+        if breakEnabled loc == enaDisa+           then return $ Left+               (text "Breakpoint" <+> text strId <+>+                text "already in desired state")+           else return $ 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++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 $ ptext (sLit "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 ptext (sLit "Stopped at")+                        else ptext (sLit "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+        wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+        maybe_info <- GHC.getModuleInfo (GHC.nameModule name)+        case maybe_info of+          Nothing -> noCanDo name (ptext (sLit "cannot get module info"))+          Just minf ->+               ASSERT( isExternalName name )+                    findBreakAndSet (GHC.nameModule name) $+                       findBreakForBind name (GHC.modInfoModBreaks minf)+       where+          noCanDo n why = printForUser $+                text "cannot set breakpoint on " <> ppr n <> text ": " <> why++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++breakSyntax :: a+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: GhciMonad m+                => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()+findBreakAndSet md lookupTickTree = do+   tickArray <- getTickArray md+   (breakArray, _) <- getModBreak md+   case lookupTickTree tickArray of+      []  -> liftIO $ putStrLn $ "No breakpoints found at that location."+      some -> mapM_ (breakAt breakArray) some+ where+   breakAt breakArray (tick, pan) = do+         setBreakFlag True breakArray tick+         (alreadySet, nm) <-+               recordBreak $ BreakLocation+                       { breakModule = md+                       , breakLoc = RealSrcSpan pan+                       , 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 (not a nested declaration)+--   (b) that do not have an enclosing breakpoint+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray+                 -> [(BreakIndex,RealSrcSpan)]+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks+  where+    ticks = [ (index, span)+            | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),+              n == occNameString (nameOccName name),+              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 `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"++-----------------------------------------------------------------------------+-- :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+        (_breakArray, 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 }++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 :: GHC.GhcMonad m => Bool -> BreakLocation -> m BreakLocation+turnBreakOnOff onOff loc+  | onOff == breakEnabled loc = return loc+  | otherwise = do+      (arr, _) <- getModBreak (breakModule loc)+      hsc_env <- GHC.getSession+      liftIO $ enableBreakpoint hsc_env arr (breakTick loc) onOff+      return loc { breakEnabled = onOff }++getModBreak :: GHC.GhcMonad m+            => Module -> m (ForeignRef BreakArray, Array Int SrcSpan)+getModBreak m = do+   mod_info      <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m+   let modBreaks  = GHC.modInfoModBreaks mod_info+   let arr        = GHC.modBreaks_flags modBreaks+   let ticks      = GHC.modBreaks_locs  modBreaks+   return (arr, ticks)++setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m ()+setBreakFlag toggle arr i = do+  hsc_env <- GHC.getSession+  liftIO $ enableBreakpoint hsc_env arr i toggle++-- ---------------------------------------------------------------------------+-- 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 arond 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+++-----------------------------------------------------------------------------+-- 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 :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+                 -- Force dflags to avoid leaking the associated HscEnv+                 !dflags <- getDynFlags+                 gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)++ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)+ghciTry m = fmap Right m `gcatch` \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.lookupModule mName Nothing++isHomeModule :: Module -> Bool+isHomeModule m = GHC.moduleUnitId m == mainUnitId++-- 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+   dflags <- getDynFlags+   when (GHC.moduleUnitId modl /= thisPackage dflags) $+      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 GHC.printException $ do+   names <- GHC.parseName str+   case names of+      []    -> return ()+      (n:_) -> do+            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++clearAllTargets :: GhciMonad m => m ()+clearAllTargets = discardActiveBreakPoints+                >> GHC.setTargets []+                >> GHC.load LoadAllTargets+                >> pure ()
+ src-bin-8.10/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,383 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -Wno-name-shadowing -Wno-compat-unqualified-imports #-}++-- | 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.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Maybe+import           Data.Data+import           Data.Function+import           Data.List+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 qualified CoreUtils+import           Desugar+import           DynFlags (HasDynFlags(..))+import           FastString+import           GHC+import           GhcMonad+import           Name+import           NameSet+import           Outputable+import           SrcLoc+import           TcHsSyn+import           Var++-- | 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.+    , modinfoInfo       :: !ModuleInfo+      -- ^ Again, useful from GHC for accessing information+      -- (exports, instances, scope) from a 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 = RealSrcSpan . spaninfoSrcSpan+        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+    tryExternalModuleResolution =+      case find (matchName $ mkFastString string)+                (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) 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 (moduleUnitId modL) <> ":" <>+                            ppr modL)) return $+             M.lookup (moduleName modL) infos++     maybe (throwE "No matching export in any local modules.") return $+         find (matchName name) (modInfoExports (modinfoInfo info))+  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+    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+            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+    liftIO (filterM cacheInvalid loaded) >>= \case+        [] -> return ms+        invalidated -> do+            liftIO (putStrLn ("Collecting type info for " +++                              show (length invalidated) +++                              " module(s) ... "))++            foldM (go df) ms invalidated+  where+    go df m name = do { info <- getModInfo name; return (M.insert name info m) }+                   `gcatch`+                   (\(e :: SomeException) -> do+                         liftIO $ putStrLn+                                $ showSDocForUser df 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+    allTypes <- processAllTypeCheckedModule typechecked+    let i = tm_checked_module_info typechecked+    ts <- liftIO $ getModificationTime $ srcFilePath m+    return (ModInfo m allTypes i ts)++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule+                            -> m [SpanInfo]+processAllTypeCheckedModule tcm = do+    bts <- mapM getTypeLHsBind $ listifyAllSpans tcs+    ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs+    pts <- mapM getTypeLPat    $ listifyAllSpans tcs+    return $ mapMaybe toSpanInfo+           $ sortBy cmpSpan+           $ catMaybes (bts ++ ets ++ pts)+  where+    tcs = tm_typechecked_source tcm++    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's+    getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+    getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})+        = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))+    getTypeLHsBind _ = pure Nothing++    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+    getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+    getTypeLHsExpr e = do+        hs_env  <- getSession+        (_,mbe) <- liftIO $ deSugarExpr hs_env e+        return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe+      where+        mid :: Maybe Id+        mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i+            | otherwise                                  = Nothing++        unwrapVar (HsWrap _ _ var) = var+        unwrapVar e'               = e'++    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's+    getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+    getTypeLPat (dL->L spn pat) =+        pure (Just (getMaybeId pat,spn,hsPatType pat))+      where+        getMaybeId (VarPat _ (dL->L _ vid)) = Just vid+        getMaybeId _                        = Nothing++    -- | Get ALL source spans in the source.+    listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]+    listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+      where+        p (dL->L spn _) = isGoodSrcSpan spn++    -- | Variant of @syb@'s @everything@ (which summarises all nodes+    -- in top-down, left-to-right order) with a stop-condition on 'NameSet's+    everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+    everythingAllSpans k z f x+      | (False `mkQ` (const True :: NameSet -> 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-8.10/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,585 @@+{-# LANGUAGE CPP, FlexibleInstances, DeriveFunctor #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++-----------------------------------------------------------------------------+--+-- 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,+        LocalConfigBehaviour(..),+        PromptFunction,+        BreakLocation(..),+        TickArray,+        getDynFlags,++        runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,+        ActionStats(..), runAndPrintStats, runWithStats, printStats,++        printForUserNeverQualify, printForUserModInfo,+        printForUser, printForUserPartWay, prettyLocations,++        compileGHCiExpr,+        initInterpBuffering,+        turnOffBuffering, turnOffBuffering_,+        flushInterpBuffers,+        mkEvalWrapper+    ) where++#include "HsVersions.h"++import Clash.GHCi.UI.Info (ModInfo)+import qualified GHC+import GhcMonad         hiding (liftIO)+import Outputable       hiding (printForUser, printForUserPartWay)+import qualified Outputable+import OccName+import DynFlags+import FastString+import HscTypes+import SrcLoc+import Module+import RdrName (mkOrig)+import PrelNames (gHC_GHCI_HELPERS)+import GHCi+import GHCi.RemoteTypes+import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import GHC.Hs.Utils+import Util++import 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+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+import qualified Data.IntMap.Strict as IntMap+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,+        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+     }++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 Bool+     -- ^ The 'Bool' value denotes whether to exit GHCi+   , 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+   }++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 Outputable.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)++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 GhcMonad GHCi where+  setSession s' = liftGhc $ setSession s'+  getSession    = liftGhc $ getSession++instance HasDynFlags (InputT GHCi) where+  getDynFlags = lift getDynFlags++instance GhcMonad (InputT GHCi) where+  setSession = lift . setSession+  getSession = lift getSession++instance ExceptionMonad GHCi where+  gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)+  gmask f =+      GHCi $ \s -> gmask $ \io_restore ->+                             let+                                g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')+                             in+                                unGHCi (f g_restore) s++instance MonadThrow Ghc where+  throwM = liftIO . throwM++instance MonadCatch Ghc where+  catch = gcatch++instance MonadMask Ghc where+  mask f = Ghc $ \s ->+    mask $ \io_restore ->+      let g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)+      in unGhc (f g_restore) s+  uninterruptibleMask f = Ghc $ \s ->+    uninterruptibleMask $ \io_restore ->+      let g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)+      in unGhc (f g_restore) s+  generalBracket acquire release use = Ghc $ \s ->+    generalBracket+      (unGhc acquire s)+      (\resource exitCase -> unGhc (release resource exitCase) s)+      (\resource -> unGhc (use resource) s)++instance MonadThrow GHCi where+  throwM = liftIO . throwM++instance MonadCatch GHCi where+  catch = gcatch++instance MonadMask GHCi where+  mask f = GHCi $ \s ->+    mask $ \io_restore ->+      let g_restore (GHCi m) = GHCi $ \s -> io_restore (m s)+      in unGHCi (f g_restore) s+  uninterruptibleMask f = GHCi $ \s ->+    uninterruptibleMask $ \io_restore ->+      let g_restore (GHCi m) = GHCi $ \s -> io_restore (m s)+      in unGHCi (f g_restore) s+  generalBracket acquire release use = GHCi $ \s ->+    generalBracket+      (unGHCi acquire s)+      (\resource exitCase -> unGHCi (release resource exitCase) s)+      (\resource -> unGHCi (use resource) s)++instance ExceptionMonad (InputT GHCi) where+  gcatch = catch+  gmask = mask++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 <- getDynFlags+  liftIO $ Outputable.printForUser dflags stdout neverQualify doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info doc = do+  dflags <- getDynFlags+  mUnqual <- GHC.mkPrintUnqualifiedForModule info+  unqual <- maybe GHC.getPrintUnqual return mUnqual+  liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+  unqual <- GHC.getPrintUnqual+  dflags <- getDynFlags+  liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUserPartWay :: GhcMonad m => SDoc -> m ()+printForUserPartWay doc = do+  unqual <- GHC.getPrintUnqual+  dflags <- getDynFlags+  liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual 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 GHC.printException 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 GHC.printException 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 GHC.printException e;+                  return Nothing)+        (Just <$> GHC.runParsedDecls decls)++resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult+resume canLogSpan step = do+  st <- getGHCiState+  reifyGHCi $ \x ->+    withProgName (progname st) $+    withArgs (args st) $+      reflectGHCi x $ do+        GHC.resumeExec canLogSpan step++-- --------------------------------------------------------------------------+-- 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 <- gtry 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 (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 . sep . reverse . show $ n+      where sep n'+              | n' `lengthAtMost` 3 = n'+              | otherwise           = take 3 n' ++ "," ++ sep (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GhciMonad m => m ()+revertCAFs = do+  hsc_env <- GHC.getSession+  liftIO $ iservCmd hsc_env 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_GHCI_HELPERS occ+  nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering"+  flush <- mkHelperExpr $ mkVarOcc "flushAll"+  return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GhciMonad m => m ()+flushInterpBuffers = do+  st <- getGHCiState+  hsc_env <- GHC.getSession+  liftIO $ evalIO hsc_env (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+  hsc_env <- getSession+  liftIO $ evalIO hsc_env 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_GHCI_HELPERS (mkVarOcc "evalWrapper")++-- | Run a 'GhcMonad' action to compile an expression for internal usage.+runInternal :: GhcMonad m => m a -> m a+runInternal =+    withTempSession mkTempSession+  where+    mkTempSession hsc_env = hsc_env+      { hsc_dflags = (hsc_dflags hsc_env) {+        -- 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+      }+        -- 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-8.10/Clash/GHCi/UI/Tags.hs view
@@ -0,0 +1,218 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -Wno-compat-unqualified-imports #-}++module Clash.GHCi.UI.Tags (+  createCTagsWithLineNumbersCmd,+  createCTagsWithRegExesCmd,+  createETagsFileCmd+) where++import Exception+import GHC+import Clash.GHCi.UI.Monad+import Outputable++-- ToDo: figure out whether we need these, and put something appropriate+-- into the GHC API instead+import Name (nameOccName)+import OccName (pprOccName)+import ConLike+import MonadUtils++import Control.Monad+import Data.Function+import Data.List+import Data.Maybe+import Data.Ord+import DriverPhases+import Panic+import Prelude+import System.Directory+import System.IO+import System.IO.Error++-----------------------------------------------------------------------------+-- create tags file for currently loaded modules.++createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,+  createETagsFileCmd :: String -> GHCi ()++createCTagsWithLineNumbersCmd ""   =+  ghciCreateTagsFile CTagsWithLineNumbers "tags"+createCTagsWithLineNumbersCmd file =+  ghciCreateTagsFile CTagsWithLineNumbers file++createCTagsWithRegExesCmd ""   =+  ghciCreateTagsFile CTagsWithRegExes "tags"+createCTagsWithRegExesCmd file =+  ghciCreateTagsFile CTagsWithRegExes file++createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"+createETagsFileCmd file  = ghciCreateTagsFile ETags file++data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes++ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()+ghciCreateTagsFile kind file = do+  createTagsFile kind file++-- ToDo:+--      - remove restriction that all modules must be interpreted+--        (problem: we don't know source locations for entities unless+--        we compiled the module.+--+--      - extract createTagsFile so it can be used from the command-line+--        (probably need to fix first problem before this is useful).+--+createTagsFile :: TagsKind -> FilePath -> GHCi ()+createTagsFile tagskind tagsFile = do+  graph <- GHC.getModuleGraph+  mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)+  either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags+  case either_res of+    Left e  -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e+    Right _ -> return ()+++listModuleTags :: GHC.Module -> GHCi [TagInfo]+listModuleTags m = do+  is_interpreted <- GHC.moduleIsInterpreted m+  -- should we just skip these?+  when (not is_interpreted) $+    let mName = GHC.moduleNameString (GHC.moduleName m) in+    throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+  mbModInfo <- GHC.getModuleInfo m+  case mbModInfo of+    Nothing -> return []+    Just mInfo -> do+       dflags <- getDynFlags+       mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo+       let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual+       let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo+       let localNames = filter ((m==) . nameModule) names+       mbTyThings <- mapM GHC.lookupName localNames+       return $! [ tagInfo dflags unqual exported kind name realLoc+                     | tyThing <- catMaybes mbTyThings+                     , let name = getName tyThing+                     , let exported = GHC.modInfoIsExportedName mInfo name+                     , let kind = tyThing2TagKind tyThing+                     , let loc = srcSpanStart (nameSrcSpan name)+                     , RealSrcLoc realLoc <- [loc]+                     ]++  where+    tyThing2TagKind (AnId _)                 = 'v'+    tyThing2TagKind (AConLike RealDataCon{}) = 'd'+    tyThing2TagKind (AConLike PatSynCon{})   = 'p'+    tyThing2TagKind (ATyCon _)               = 't'+    tyThing2TagKind (ACoAxiom _)             = 'x'+++data TagInfo = TagInfo+  { tagExported :: Bool -- is tag exported+  , tagKind :: Char   -- tag kind+  , tagName :: String -- tag name+  , tagFile :: String -- file name+  , tagLine :: Int    -- line number+  , tagCol :: Int     -- column number+  , tagSrcInfo :: Maybe (String,Integer)  -- source code line and char offset+  }+++-- get tag info, for later translation into Vim or Emacs style+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc+        -> TagInfo+tagInfo dflags unqual exported kind name loc+    = TagInfo exported kind+        (showSDocForUser dflags unqual $ pprOccName (nameOccName name))+        (showSDocForUser dflags unqual $ ftext (srcLocFile loc))+        (srcLocLine loc) (srcLocCol loc) Nothing++-- throw an exception when someone tries to overwrite existing source file (fix for #10989)+writeTagsSafely :: FilePath -> String -> IO ()+writeTagsSafely file str = do+    dfe <- doesFileExist file+    if dfe && isSourceFilename file+        then throwGhcException (CmdLineError (file ++ " is existing source file. " +++             "Please specify another file name to store tags data"))+        else writeFile file str++collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())+-- ctags style with the Ex expression being just the line number, Vim et al+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do+  let tags = unlines $ sort $ map showCTag tagInfos+  tryIO (writeTagsSafely file tags)++-- ctags style with the Ex expression being a regex searching the line, Vim et al+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al+  tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos+  let tags = unlines $ sort $ map showCTag $concat tagInfoGroups+  tryIO (writeTagsSafely file tags)++collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs+  tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos+  let tagGroups = map processGroup tagInfoGroups+  tryIO (writeTagsSafely file $ concat tagGroups)++  where+    processGroup [] = throwGhcException (CmdLineError "empty tag file group??")+    processGroup group@(tagInfo:_) =+      let tags = unlines $ map showETag group in+      "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags+++makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]+makeTagGroupsWithSrcInfo tagInfos = do+  let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos+  mapM addTagSrcInfo groups++  where+    addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")+    addTagSrcInfo group@(tagInfo:_) = do+      file <- readFile $tagFile tagInfo+      let sortedGroup = sortBy (comparing tagLine) group+      return $ perFile sortedGroup 1 0 $ lines file++    perFile allTags@(tag:tags) cnt pos allLs@(l:ls)+     | tagLine tag > cnt =+         perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls+     | tagLine tag == cnt =+         tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs+    perFile _ _ _ _ = []+++-- ctags format, for Vim et al+showCTag :: TagInfo -> String+showCTag ti =+  tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" +++    tagKind ti : ( if tagExported ti then "" else "\tfile:" )++  where+    tagCmd =+      case tagSrcInfo ti of+        Nothing -> show $tagLine ti+        Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"++      where+        escapeSlashes '/' r = '\\' : '/' : r+        escapeSlashes '\\' r = '\\' : '\\' : r+        escapeSlashes c r = c : r+++-- etags format, for Emacs/XEmacs+showETag :: TagInfo -> String+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,+                  tagSrcInfo = Just (srcLine,charPos) }+    =  take (colNo - 1) srcLine ++ tag+    ++ "\x7f" ++ tag+    ++ "\x01" ++ show lineNo+    ++ "," ++ show charPos+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+ src-bin-8.10/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-8.10/Clash/Main.hs view
@@ -0,0 +1,1071 @@+{-# 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) where++-- The official GHC API+import qualified GHC+import GHC              ( -- DynFlags(..), HscTarget(..),+                          -- GhcMode(..), GhcLink(..),+                          Ghc, GhcMonad(..),+                          LoadHowMuch(..) )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface        ( showIface )+import HscMain          ( newHscEnv )+import DriverPipeline   ( oneShot, compileFile )+import DriverMkDepend   ( doMkDependHS )+import DriverBkp   ( doBackpack )+#if defined(HAVE_INTERNAL_INTERPRETER)+import Clash.GHCi.UI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++-- Frontend plugins+import DynamicLoading   ( loadFrontendPlugin )+import Plugins+#if defined(HAVE_INTERNAL_INTERPRETER)+import DynamicLoading   ( initializePlugins )+#endif+import Module           ( ModuleName )+++-- Various other random stuff that we need+import GHC.HandleEncoding+import GHC.Platform+import GHC.Platform.Host+import Config+import Constants+import HscTypes+import Packages         ( pprPackages, pprPackagesSimple )+import DriverPhases+import BasicTypes       ( failed )+import DynFlags hiding (WarnReason(..))+import ErrUtils+import FastString+import Outputable+import SysTools.BaseDir+import SysTools.Settings+import SrcLoc+import Util+import Panic+import UniqSupply+import MonadUtils       ( liftIO )++-- Imports for --abi-hash+import LoadIface           ( loadUserInterface )+import Module              ( mkModuleName )+import Finder              ( findImportedModule, cannotFindModule )+import TcRnMonad           ( initIfaceCheck )+import Binary              ( openBinMem, put_ )+import BinFingerprint      ( fingerprintBinMem )++-- 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 ( isPrefixOf, partition, intercalate, nub )+import Data.Maybe++-- clash additions+import           Paths_clash_ghc+import           Clash.GHCi.Common (checkClashDynamic)+import           Clash.GHCi.UI (makeHDL)+import           Exception (gcatch)+import           Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Version (showVersion)++import qualified Clash.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.Netlist.BlackBox.Types (HdlSyn (..))+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 = flip withArgs $ do+   initGCStatistics -- See Note [-Bsymbolic and hooks]+   hSetBuffering stdout LineBuffering+   hSetBuffering stderr LineBuffering++   configureHandleEncoding+   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+    -- 1. extract the -B flag from the args+    argv0 <- getArgs++    -- let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0+    --     mbMinusB | null minusB_args = Nothing+    --              | otherwise = Just (drop 2 (last minusB_args))++    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, 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+            liftIO (checkClashDynamic dflags)+            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+                                  { DynFlags.pluginModNames = nub $+                                      ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+                                      ghcTyLitKNPlugin :+                                      DynFlags.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 dflagsExtra1 argv3 flagWarnings r++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]+      -> IORef ClashOpts+      -> Ghc ()+main' postLoadMode dflags0 args flagWarnings clashOpts = do+  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget+  -- can be further adjusted on a module by module basis, using only+  -- the -fvia-C and -fasm flags.  If the default HscTarget is not+  -- HscC or HscAsm, -fvia-C and -fasm have no effect.+  let dflt_target = hscTarget dflags0+      (mode, lang, link)+         = case postLoadMode of+               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)+               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)+               DoMake          -> (CompManager, dflt_target,    LinkBinary)+               DoBackpack      -> (CompManager, dflt_target,    LinkBinary)+               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)+               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)+               DoVHDL          -> (CompManager, HscNothing,     NoLink)+               DoVerilog       -> (CompManager, HscNothing,     NoLink)+               DoSystemVerilog -> (CompManager, HscNothing,     NoLink)+               _               -> (OneShot,     dflt_target,    LinkBinary)++  let dflags1 = dflags0{ ghcMode   = mode,+                         hscTarget = lang,+                         ghcLink   = link,+                         verbosity = case postLoadMode of+                                         DoEval _ -> 0+                                         _other   -> 1+                        }++      -- turn on -fimplicit-import-qualified for GHCi now, so that it+      -- can be overriden 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+               | otherwise                     = dflags1+        where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified+                                       `gopt_set` Opt_IgnoreOptimChanges+                                       `gopt_set` Opt_IgnoreHpcChanges++        -- The rest of the arguments are "dynamic"+        -- Leftover ones are presumably files+  (dflags3, fileish_args, dynamicFlagWarnings) <-+      GHC.parseDynamicFlags dflags2 args++  let dflags4 = case lang of+                HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->+                    let platform = targetPlatform dflags3+                        dflags3a = updateWays $ dflags3 { ways = interpWays }+                        dflags3b = foldl gopt_set dflags3a+                                 $ concatMap (wayGeneralFlags platform)+                                             interpWays+                        dflags3c = foldl gopt_unset dflags3b+                                 $ concatMap (wayUnsetGeneralFlags platform)+                                             interpWays+                    in dflags3c+                _ ->+                    dflags3++  GHC.prettyPrintGhcErrors dflags4 $ do++  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings++  handleSourceError (\e -> do+       GHC.printException e+       liftIO $ exitWith (ExitFailure 1)) $ do+         liftIO $ handleFlagWarnings dflags4 flagWarnings'++  liftIO $ showBanner postLoadMode dflags4++  let+     -- To simplify the handling of filepaths, we normalise all filepaths right+     -- away. Note the asymmetry of FilePath.normalise:+     --    Linux:   p/q -> p/q; p\q -> p\q+     --    Windows: p/q -> p\q; p\q -> p\q+     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs+     -- to -foo.hs. We have to re-prepend the current directory.+    normalise_hyp fp+        | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp+        | otherwise                           = nfp+        where+#if defined(mingw32_HOST_OS)+          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp+#else+          strt_dot_sl = "./" `isPrefixOf` fp+#endif+          cur_dir = '.' : [pathSeparator]+          nfp = normalise fp+    normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args+    (srcs, objs)         = partition_args normal_fileish_paths [] []++    dflags5 = dflags4 { ldInputs = map (FileOption "") objs+                                   ++ ldInputs dflags4 }++  -- we've finished manipulating the DynFlags, update the session+  _ <- GHC.setSessionDynFlags dflags5+  dflags6 <- GHC.getSessionDynFlags+  hsc_env <- GHC.getSession++        ---------------- Display configuration -----------+  case verbosity dflags6 of+    v | v == 4 -> liftIO $ dumpPackagesSimple dflags6+      | v >= 5 -> liftIO $ dumpPackages dflags6+      | otherwise -> return ()++  liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)+        ---------------- Final sanity checking -----------+  liftIO $ checkOptions postLoadMode dflags6 srcs objs++  ---------------- Do the business -----------+  handleSourceError (\e -> do+       GHC.printException e+       liftIO $ exitWith (ExitFailure 1)) $ do+    clashOpts' <- liftIO (readIORef clashOpts)+    let clash fun = gcatch (fun clashOpts srcs) (handleClashException dflags6 clashOpts')+    case postLoadMode of+       ShowInterface f        -> liftIO $ doShowIface dflags6 f+       DoMake                 -> doMake srcs+       DoMkDependHS           -> doMkDependHS (map fst srcs)+       StopBefore p           -> liftIO (oneShot hsc_env p srcs)+       DoInteractive          -> ghciUI clashOpts hsc_env dflags6 srcs Nothing+       DoEval exprs           -> ghciUI clashOpts hsc_env dflags6 srcs $ Just $+                                   reverse exprs+       DoAbiHash              -> abiHash (map fst srcs)+       ShowPackages           -> liftIO $ showPackages dflags6+       DoFrontend f           -> doFrontend f srcs+       DoBackpack             -> doBackpack (map fst srcs)+       DoVHDL                 -> clash makeVHDL+       DoVerilog              -> clash makeVerilog+       DoSystemVerilog        -> clash makeSystemVerilog++  liftIO $ dumpFinalStats dflags6++ghciUI :: IORef ClashOpts -> HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]+       -> Ghc ()+#if !defined(HAVE_INTERNAL_INTERPRETER)+ghciUI _ _ _ _ _ =+  throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI clashOpts hsc_env dflags0 srcs maybe_expr = do+  dflags1 <- liftIO (initializePlugins hsc_env dflags0)+  _ <- GHC.setSessionDynFlags dflags1+  interactiveUI (defaultGhciSettings clashOpts) srcs maybe_expr+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files.  This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.++partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+               -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+  | "none" <- suff      = partition_args args srcs objs+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs+        where phase = startPhase suff+              (slurp,rest) = break (== "-x") args+              these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+  | otherwise               = partition_args args srcs (arg:objs)++    {-+      We split out the object files (.o, .dll) and add them+      to ldInputs for use by the linker.++      The following things should be considered compilation manager inputs:++       - haskell source files (strings ending in .hs, .lhs or other+         haskellish extension),++       - module names (not forgetting hierarchical module names),++       - things beginning with '-' are flags that were not recognised by+         the flag parser, and we want them to generate errors later in+         checkOptions, so we class them as source files (#5921)++       - and finally we consider everything without an extension to be+         a comp manager input, as shorthand for a .hs or .lhs filename.++      Everything else is considered to be a linker object, and passed+      straight through to the linker.+    -}+looks_like_an_input :: String -> Bool+looks_like_an_input m =  isSourceFilename m+                      || looksLikeModuleName m+                      || "-" `isPrefixOf` m+                      || not (hasExtension m)++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+     -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions mode dflags srcs objs = do+     -- Complain about any unknown flags+   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++   when (notNull (filter wayRTSOnly (ways dflags))+         && isInterpretiveMode mode) $+        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++        -- -prof and --interactive are not a good combination+   when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)+         && 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++        -- -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+        then throwGhcException (UsageError "no input files")+        else do++   case mode of+      StopBefore HCc | hscTarget dflags /= HscC+        -> throwGhcException $ UsageError $+           "the option -C is only available with an unregisterised GHC"+      StopBefore (As False) | 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 Phase        -- 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"]+  | 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,+  doAbiHashMode, showPackagesMode, doVHDLMode, doVerilogMode,+  doSystemVerilogMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doAbiHashMode = mkPostLoadMode DoAbiHash+showPackagesMode = mkPostLoadMode ShowPackages+doVHDLMode = mkPostLoadMode DoVHDL+doVerilogMode = mkPostLoadMode DoVerilog+doSystemVerilogMode = mkPostLoadMode DoSystemVerilog++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: Phase -> 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 StopLn))) = 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 StopLn) = True+isLinkMode DoMake              = True+isLinkMode DoInteractive       = True+isLinkMode (DoEval _)          = True+isLinkMode _                   = False++isCompManagerMode :: PostLoadMode -> Bool+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,+                      [Located String],+                      [Warn])+parseModeFlags args = do+  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =+          runCmdLine (processArgs mode_flags args)+                     (Nothing, [], [])+      mode = case mModeFlag of+             Nothing     -> doMakeMode+             Just (m, _) -> m++  -- See Note [Handling errors when parsing commandline flags]+  unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $+      map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2++  return (mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe (Mode, 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 showPackagesMode))+  ] +++  [ 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",+          "ld 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 StopLn) f+                                               addFlag "-no-link" f))+  , defFlag "M"            (PassFlag (setMode doMkDependHSMode))+  , defFlag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))+  , defFlag "C"            (PassFlag (setMode (stopBeforeMode HCc)))+  , defFlag "S"            (PassFlag (setMode (stopBeforeMode (As False))))+  , defFlag "-make"        (PassFlag (setMode doMakeMode))+  , 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))+  ]++setMode :: Mode -> String -> EwM ModeM ()+setMode newMode newFlag = liftEwM $ do+    (mModeFlag, 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', 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, e, flags') <- getCmdLineState+  putCmdLineState (m, e, mkGeneralLocated loc s : flags')+    where loc = "addFlag by " ++ flag ++ " on the commandline"++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake 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 StopLn srcs)+       else do++    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)+                 non_hs_srcs+    dflags <- GHC.getSessionDynFlags+    let dflags' = dflags { ldInputs = map (FileOption "") o_files+                                      ++ ldInputs dflags }+    _ <- GHC.setSessionDynFlags dflags'++    targets <- mapM (uncurry GHC.guessTarget) hs_srcs+    GHC.setTargets targets+    ok_flag <- GHC.load LoadAllTargets++    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+    return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+  hsc_env <- newHscEnv dflags+  showIface hsc_env file++-- ---------------------------------------------------------------------------+-- 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 ErrUtils 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+  targetPlatformMini <- case res of+    Right s -> pure $ platformMini $ 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 cHostPlatformMini+    Left (SettingsError_BadData msg) -> do+      hPutStrLn stderr msg+      exitWith $ ExitFailure 1+  mapM_ putStrLn $ supportedLanguagesAndExtensions targetPlatformMini++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+  dump usage+  where+     dump ""          = return ()+     dump ('$':'$':s) = putStr progName >> dump s+     dump (c:s)       = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags =+  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = 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 dflags msg+  where+   x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'++showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()+showPackages       dflags = putStrLn (showSDoc dflags (pprPackages dflags))+dumpPackages       dflags = putMsg dflags (pprPackages dflags)+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)++-- -----------------------------------------------------------------------------+-- Frontend plugin support++doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()+doFrontend modname srcs = do+    hsc_env <- getSession+    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname+    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 chagnes, 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 Nothing+         case r of+           Found _ m -> return m+           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $+                          cannotFindModule dflags modname r++  mods <- mapM find_it strs++  let get_iface modl = loadUserInterface False (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' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) ->  backend)+         -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' _       _ []   = throwGhcException (CmdLineError "No input files")+makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs++makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVHDL = makeHDL' (Clash.Backend.initBackend @VHDLState)++makeVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend @VerilogState)++makeSystemVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend @SystemVerilogState)++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+  where+    oneError f =+        "unrecognised flag: " ++ f ++ "\n" +++        (case match f (nubSort allNonDeprecatedFlags) of+            [] -> ""+            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))+    -- fixes #11789+    -- If the flag contains '=',+    -- this uses both the whole and the left side of '=' for comparing.+    match f allFlags+        | elem '=' f =+              let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags+                  fName = takeWhile (/= '=') f+              in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+        | otherwise = fuzzyMatch f allFlags++{- Note [-Bsymbolic and hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-Bsymbolic is a flag that prevents the binding of references to global+symbols to symbols outside the shared library being compiled (see `man+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS+package: that is because we want hooks to be overridden by the user,+we don't want to constrain them to the RTS package.++Unfortunately this seems to have broken somehow on OS X: as a result,+defaultHooks (in hschooks.c) is not called, which does not initialize+the GC stats. As a result, this breaks things like `:set +s` in GHCi+(#8754). As a hacky workaround, we instead call 'defaultHooks'+directly to initalize the flags in the RTS.++A byproduct of this, I believe, is that hooks are likely broken on OS+X when dynamically linking. But this probably doesn't affect most+people since we're linking GHC dynamically, but most things themselves+link statically.+-}++-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then+-- running it causes an error like this:+--+-- Loading temp shared object failed:+-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics+--+-- Skipping the foreign call fixes this problem, and the outer GHCi+-- should have already made this call anyway.+#if defined(GHC_LOADED_INTO_GHCI)+initGCStatistics :: IO ()+initGCStatistics = return ()+#else+foreign import ccall safe "initGCStatistics"+  initGCStatistics :: IO ()+#endif
src-bin-841/Clash/GHCi/UI.hs view
@@ -2000,6 +2000,8 @@                 let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]                 (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-                   generateBindings color primDirs idirs dbs hdl src (Just dflags)+                let getMain = getMainTopEntity src bindingsMap topEntities+                mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)                 prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime                 let prepStartDiff = reportTimeDiff prepTime startTime                 putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff@@ -2015,6 +2017,7 @@                   (ghcTypeToHWType iw fp)                   primEvaluator                   topEntities+                  mainTopEntity                   opts2                   (startTime,prepTime)
src-bin-861/Clash/GHCi/UI.hs view
@@ -2049,6 +2049,8 @@                 let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]                 (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-                   generateBindings color primDirs idirs dbs hdl src (Just dflags)+                let getMain = getMainTopEntity src bindingsMap topEntities+                mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)                 prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime                 let prepStartDiff = reportTimeDiff prepTime startTime                 putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff@@ -2064,6 +2066,7 @@                   (ghcTypeToHWType iw fp)                   primEvaluator                   topEntities+                  mainTopEntity                   opts2                   (startTime,prepTime)
src-bin-881/Clash/GHCi/UI.hs view
@@ -2140,6 +2140,9 @@                 let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]                 (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <-                   generateBindings color primDirs idirs dbs hdl src (Just dflags)++                let getMain = getMainTopEntity src bindingsMap topEntities+                mainTopEntity <- traverse getMain (GHC.mainFunIs dflags)                 prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime                 let prepStartDiff = reportTimeDiff prepTime startTime                 putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff@@ -2155,6 +2158,7 @@                   (ghcTypeToHWType iw fp)                   primEvaluator                   topEntities+                  mainTopEntity                   opts2                   (startTime,prepTime)
src-bin-common/Clash/GHCi/Common.hs view
@@ -1,26 +1,75 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE QuasiQuotes #-}  module Clash.GHCi.Common   ( checkImportDirs   , checkMonoLocalBinds   , checkMonoLocalBindsMod   , checkClashDynamic+  , getMainTopEntity   ) where  -- Clash-import           Clash.Driver.Types     (ClashOpts (..))+import           Clash.Driver.Types     (ClashOpts (..), BindingMap)+import           Clash.Netlist.Types    (TopEntityT(..))  -- The GHC interface import qualified DynFlags import qualified EnumSet                as GHC (member) import qualified GHC                    (DynFlags, ModSummary (..), Module (..),                                          extensionFlags, moduleNameString)+import           Clash.Core.Name        (nameOcc)+import           Clash.Core.Var         (varName)+import           Clash.Normalize.Util   (collectCallGraphUniques, callGraph)+import qualified Clash.Util.Interpolate as I+import           Clash.Util             (ClashException(..), HasCallStack, noSrcSpan)+import           Clash.Unique           (getUnique)+import           Control.Exception      (throw)+import           Data.List              (isSuffixOf)+import qualified Data.Text              as Text+import qualified Data.HashSet           as HashSet import qualified GHC.LanguageExtensions as LangExt (Extension (..)) import           Panic                  (GhcException (..), throwGhcException)  import           Control.Monad          (forM_, unless, when) import           System.Directory       (doesDirectoryExist) import           System.IO              (hPutStrLn, stderr)++getMainTopEntity+  :: HasCallStack+  => String+  -- ^ Module name+  -> BindingMap+  -- ^ Map of global binders+  -> [TopEntityT]+  -- ^ List of top entities loaded by LoadModules+  -> String+  -- ^ string passed with -main-is+  -> IO (TopEntityT, [TopEntityT])+  -- ^ Throws exception if -main-is was set, but no such top entity was found.+  -- Otherwise, returns main top entity and all top entities (transitively) used+  -- in the main top entity.+getMainTopEntity modName bindingMap topEnts nm =+  case filter isNm topEnts of+    [] -> throw $ ClashException noSrcSpan [I.i|+      Could not find top entity called #{show nm} in #{show modName}+    |] Nothing+    [t] ->+      let+        closure0 = collectCallGraphUniques (callGraph bindingMap (topId t))+        closure1 = HashSet.delete (getUnique (topId t)) closure0+      in+        pure (t, filter ((`HashSet.member` closure1) . getUnique . topId) topEnts)+    ts ->+      error $ [I.i|+        Internal error: multiple top entities called #{nm} (#{map topId ts})+        found in #{modName}.+      |]+ where+  isNm (TopEntityT{topId}) =+    let topIdNm = Text.unpack (nameOcc (varName topId)) in+    topIdNm == nm || ('.':nm) `isSuffixOf` topIdNm  -- | Checks whether MonoLocalBinds language extension is enabled or not in -- modules.
src-ghc/Clash/GHC/ClashFlags.hs view
@@ -63,6 +63,8 @@ flagsClash r = [     defFlag "fclash-debug"                       $ SepArg (setDebugLevel r)   , defFlag "fclash-debug-transformations"       $ SepArg (setDebugTransformations r)+  , defFlag "fclash-debug-transformations-from"  $ OptIntSuffix (setDebugTransformationsFrom r)+  , defFlag "fclash-debug-transformations-limit" $ OptIntSuffix (setDebugTransformationsLimit r)   , defFlag "fclash-hdldir"                      $ SepArg (setHdlDir r)   , defFlag "fclash-hdlsyn"                      $ SepArg (setHdlSyn r)   , defFlag "fclash-nocache"                     $ NoArg (deprecated "nocache" "no-cache" setNoCache r)@@ -137,6 +139,16 @@  where   transformations = Set.fromList (filter (not . null) (map trim (splitOn "," s)))   trim = dropWhileEnd isSpace . dropWhile isSpace++setDebugTransformationsFrom :: IORef ClashOpts -> Maybe Int -> EwM IO ()+setDebugTransformationsFrom r (Just n) =+  liftEwM (modifyIORef r (\c -> c {opt_dbgTransformationsFrom = n}))+setDebugTransformationsFrom _r Nothing = pure ()++setDebugTransformationsLimit :: IORef ClashOpts -> Maybe Int -> EwM IO ()+setDebugTransformationsLimit r (Just n) =+  liftEwM (modifyIORef r (\c -> c {opt_dbgTransformationsLimit = n}))+setDebugTransformationsLimit _r Nothing = pure ()  setDebugLevel :: IORef ClashOpts               -> String
src-ghc/Clash/GHC/Evaluator.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}@@ -16,6 +17,7 @@  module Clash.GHC.Evaluator   ( primEvaluator+  , isUndefinedPrimVal   ) where  import           Control.Concurrent.Supply  (Supply,freshId)@@ -52,10 +54,7 @@  import           BasicTypes          (Boxity (..)) import           Name                (getSrcSpan, nameOccName, occNameString)-import           PrelNames-  (typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey,-   trueDataConKey, falseDataConKey)-import           SrcLoc              (wiredInSrcSpan)+import           PrelNames           (trueDataConKey, falseDataConKey) import qualified TyCon import           TysWiredIn          (tupleTyCon) import           Unique              (getKey)@@ -70,7 +69,7 @@ import           Clash.Core.Pretty   (showPpr) import           Clash.Core.Term   (Pat (..), PrimInfo (..), Term (..), WorkInfo (..), mkApps)-import           Clash.Core.TermInfo (piResultTys)+import           Clash.Core.TermInfo (piResultTys, applyTypeToArgs) import           Clash.Core.Type   (Type (..), ConstTy (..), LitTy (..), TypeView (..), mkFunTy, mkTyConApp,    splitFunForallTy, tyView)@@ -81,12 +80,15 @@   (mkRTree,mkVec,tyNatSize,dataConInstArgTys,primCo,    undefinedTm) import           Clash.Core.Var      (mkLocalId, mkTyVar)-import           Clash.Debug         (trace)+import           Clash.Debug import           Clash.GHC.GHC2Core  (modNameM) import           Clash.Rewrite.Util  (mkSelectorCase) import           Clash.Unique        (lookupUniqMap) import           Clash.Util   (MonadUnique (..), clogBase, flogBase, curLoc)+import           Clash.Normalize.PrimitiveReductions+  (typeNatMul, typeNatSub, typeNatAdd, vecLastPrim, vecInitPrim, vecHeadPrim,+   vecTailPrim, mkVecCons, mkVecNil)  import Clash.Promoted.Nat.Unsafe (unsafeSNat) import qualified Clash.Sized.Internal.BitVector as BitVector@@ -97,7 +99,6 @@ import Clash.Sized.Internal.Unsigned (Unsigned (..)) import Clash.XException (isX) - primEvaluator :: PrimEvaluator primEvaluator = (reduceConstant, unwindPrim) @@ -106,53 +107,72 @@ -- TODO This should really be in Clash.GHC.Evaluator -- the evaluator in -- clash-lib should NEVER refer to GHC primitives. unwindPrim :: PrimUnwind-unwindPrim tcm ty tys vs v [] m-  | primName ty `elem` [ "Clash.Sized.Internal.Index.fromInteger#"+unwindPrim tcm p tys vs v [] m+  | primName p `elem` [ "Clash.Sized.Internal.Index.fromInteger#"                        , "GHC.CString.unpackCString#"                        , "Clash.Transformations.removedArg"                        , "GHC.Prim.MutableByteArray#"+                       , "Clash.Transformations.undefined"                        ]               -- The above primitives are actually values, and not operations.-  = unwind tcm m (PrimVal ty tys (vs ++ [v]))-  | primName ty == "Clash.Sized.Internal.BitVector.fromInteger#"+  = unwind tcm m (PrimVal p tys (vs ++ [v]))+  | primName p == "Clash.Sized.Internal.BitVector.fromInteger#"   = case (vs,v) of     ([naturalLiteral -> Just n,mask], integerLiteral -> Just i) ->-      unwind tcm m (PrimVal ty tys [Lit (NaturalLiteral n)-                                             ,mask-                                             ,Lit (IntegerLiteral (wrapUnsigned n i))])+      unwind tcm m (PrimVal p tys [Lit (NaturalLiteral n), mask, Lit (IntegerLiteral (wrapUnsigned n i))])     _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))-  | primName ty == "Clash.Sized.Internal.BitVector.fromInteger##"+  | primName p == "Clash.Sized.Internal.BitVector.fromInteger##"   = case (vs,v) of     ([mask], integerLiteral -> Just i) ->-      unwind tcm m (PrimVal ty tys [mask-                                             ,Lit (IntegerLiteral (wrapUnsigned 1 i))])+      unwind tcm m (PrimVal p tys [mask, Lit (IntegerLiteral (wrapUnsigned 1 i))])     _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))-  | primName ty == "Clash.Sized.Internal.Signed.fromInteger#"+  | primName p == "Clash.Sized.Internal.Signed.fromInteger#"   = case (vs,v) of     ([naturalLiteral -> Just n],integerLiteral -> Just i) ->-      unwind tcm m (PrimVal ty tys [Lit (NaturalLiteral n)-                                             ,Lit (IntegerLiteral (wrapSigned n i))])+      unwind tcm m (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapSigned n i))])     _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))-  | primName ty == "Clash.Sized.Internal.Unsigned.fromInteger#"+  | primName p == "Clash.Sized.Internal.Unsigned.fromInteger#"   = case (vs,v) of     ([naturalLiteral -> Just n],integerLiteral -> Just i) ->-      unwind tcm m (PrimVal ty tys [Lit (NaturalLiteral n)-                                             ,Lit (IntegerLiteral (wrapUnsigned n i))])+      unwind tcm m (PrimVal p tys [Lit (NaturalLiteral n), Lit (IntegerLiteral (wrapUnsigned n i))])     _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))-  | otherwise = mPrimStep m tcm (forcePrims m) ty tys (vs ++ [v]) m+  | isUndefinedPrimVal v+  = let tyArgs = map Right tys+        tmArgs = map (Left . valToTerm) (vs ++ [v])+    in  Just $ flip setTerm m $ undefinedTm $+          applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+  | otherwise+  = mPrimStep m tcm (forcePrims m) p tys (vs ++ [v]) m -unwindPrim tcm ty tys vs v [e] m0-  | primName ty `elem` [ "Clash.Sized.Vector.lazyV"+unwindPrim tcm p tys vs v [e] m0+  -- 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.||"                        ]-  = let (m1,i) = newLetBinding tcm m0 e-    in  mPrimStep m0 tcm (forcePrims m0) ty tys (vs ++ [v,Suspend (Var i)]) m1+  = if isUndefinedPrimVal v then+      let tyArgs = map Right tys+          tmArgs = map (Left . valToTerm) (vs ++ [v]) ++ [Left e]+      in  Just $ flip setTerm m0 $ undefinedTm $+            applyTypeToArgs (Prim p) tcm (primType p) (tyArgs ++ tmArgs)+    else+      let (m1,i) = newLetBinding tcm m0 e+      in  mPrimStep m0 tcm (forcePrims m0) p tys (vs ++ [v,Suspend (Var i)]) m1 -unwindPrim _ ty tys vs (collectValueTicks -> (v, ts)) (e:es) m =-  Just . setTerm e $ stackPush (PrimApply ty tys (vs ++ [foldr TickValue v ts]) es) m+unwindPrim 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 $ undefinedTm $+          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)@@ -454,6 +474,19 @@   "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] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . bitReverse64 . fromInteger $ i+#endif+ ------------ -- Narrowing ------------@@ -2978,6 +3011,31 @@                          ,Left (Either.lefts vArgs !! 2)                          ]) +  -- :: 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 = lookupUniqMap 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@@ -3804,47 +3862,6 @@   -> Term mkIndexLit' (rTy,nTy,kn) = mkIndexLit rTy nTy kn --- | Create a vector of supplied elements-mkVecCons-  :: DataCon-  -- ^ The Cons (:>) constructor-  -> Type-  -- ^ Element type-  -> Integer-  -- ^ Length of the vector-  -> Term-  -- ^ head of the vector-  -> Term-  -- ^ tail of the vector-  -> Term-mkVecCons consCon resTy n h t =-  mkApps (Data consCon) [Right (LitTy (NumTy n))-                        ,Right resTy-                        ,Right (LitTy (NumTy (n-1)))-                        ,Left (primCo consCoTy)-                        ,Left h-                        ,Left t]--  where-    args = dataConInstArgTys consCon [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))]-    Just (consCoTy : _) = args---- | Create an empty vector-mkVecNil-  :: DataCon-  -- ^ The Nil constructor-  -> Type-  -- ^ The element type-  -> Term-mkVecNil nilCon resTy =-  mkApps (Data nilCon) [Right (LitTy (NumTy 0))-                       ,Right resTy-                       ,Left  (primCo nilCoTy)-                       ]-  where-    args = dataConInstArgTys nilCon [LitTy (NumTy 0),resTy]-    Just (nilCoTy : _ ) = args- boolToIntLiteral :: Bool -> Term boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0) @@ -4077,72 +4094,6 @@         r = f a     in  Literal . FloatLiteral . toRational $ F# r -vecHeadPrim-  :: TyConName-  -- ^ Vec TyCon name-  -> Term-vecHeadPrim vecTcNm =-  Prim (PrimInfo "Clash.Sized.Vector.head" (vecHeadTy vecTcNm) WorkNever)--vecLastPrim-  :: TyConName-  -- ^ Vec TyCon name-  -> Term-vecLastPrim vecTcNm =-  Prim (PrimInfo "Clash.Sized.Vector.last" (vecHeadTy vecTcNm) WorkNever)--vecHeadTy-  :: TyConName-  -- ^ Vec TyCon name-  -> Type-vecHeadTy vecNm =-    ForAllTy nTV (-    ForAllTy aTV (-    mkFunTy-      (mkTyConApp vecNm [mkTyConApp typeNatAdd-                           [VarTy nTV-                           ,LitTy (NumTy 1)]-                        ,VarTy aTV-                        ])-      (VarTy aTV)))-  where-    aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)-    nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)--vecTailPrim-  :: TyConName-  -- ^ Vec TyCon name-  -> Term-vecTailPrim vecTcNm =-  Prim (PrimInfo "Clash.Sized.Vector.tail" (vecTailTy vecTcNm) WorkNever)--vecInitPrim-  :: TyConName-  -- ^ Vec TyCon name-  -> Term-vecInitPrim vecTcNm =-  Prim (PrimInfo "Clash.Sized.Vector.init" (vecTailTy vecTcNm) WorkNever)--vecTailTy-  :: TyConName-  -- ^ Vec TyCon name-  -> Type-vecTailTy vecNm =-    ForAllTy nTV (-    ForAllTy aTV (-    mkFunTy-      (mkTyConApp vecNm [mkTyConApp typeNatAdd-                           [VarTy nTV-                           ,LitTy (NumTy 1)]-                        ,VarTy aTV-                        ])-      (mkTyConApp vecNm [VarTy nTV-                        ,VarTy aTV-                        ])))-  where-    nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)-    aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)- splitAtPrim   :: TyConName   -- ^ SNat TyCon name@@ -4366,25 +4317,6 @@     nTV   = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)     mTV   = mkTyVar typeNatKind (mkUnsafeSystemName "m" 1)     tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)--typeNatAdd :: TyConName-typeNatAdd = Name User-                  "GHC.TypeNats.+"-                  (getKey typeNatAddTyFamNameKey)-                  wiredInSrcSpan---typeNatMul :: TyConName-typeNatMul = Name User-                  "GHC.TypeNats.*"-                  (getKey typeNatMulTyFamNameKey)-                  wiredInSrcSpan--typeNatSub :: TyConName-typeNatSub = Name User-                  "GHC.TypeNats.-"-                  (getKey typeNatSubTyFamNameKey)-                  wiredInSrcSpan  ghcTyconToTyConName   :: TyCon.TyCon
src-ghc/Clash/GHC/GHC2Core.hs view
@@ -68,7 +68,13 @@ import DynFlags   (unsafeGlobalDynFlags) import FamInstEnv (FamInst (..), FamInstEnvs,                    familyInstances)++#if MIN_VERSION_ghc(8,10,0)+import FastString (unpackFS, bytesFS)+#else import FastString (unpackFS, fastStringToByteString)+#endif+ import Id         (isDataConId_maybe) import IdInfo     (IdDetails (..), unfoldingInfo) import Literal    (Literal (..))@@ -268,7 +274,13 @@ #else   SumTyCon dcs -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs #endif-  NewTyCon dc _ (rhsTvs,rhsEtad) _ -> Just <$> (C.NewTyCon <$> coreToDataCon dc++#if MIN_VERSION_ghc(8,10,0)+  NewTyCon dc _ (rhsTvs,rhsEtad) _ _ ->+#else+  NewTyCon dc _ (rhsTvs,rhsEtad) _ ->+#endif+                                      Just <$> (C.NewTyCon <$> coreToDataCon dc                                                            <*> ((,) <$> mapM coreToTyVar rhsTvs                                                                     <*> coreToType rhsEtad                                                                )@@ -644,7 +656,11 @@     mkDc dcTy repTys   where     mkDc dcTy repTys = do+#if MIN_VERSION_ghc(8,10,0)+      let decLabel = decodeUtf8 . bytesFS . flLabel+#else       let decLabel = decodeUtf8 . fastStringToByteString . flLabel+#endif       let fLabels  = map decLabel (dataConFieldLabels dc)        nm   <- coreToName dataConName getUnique qualifiedNameString dc@@ -843,7 +859,12 @@ #else coreToType' (ForAllTy (TvBndr tv _) ty) = C.ForAllTy <$> coreToTyVar tv <*> coreToType ty #endif+#if MIN_VERSION_ghc(8,10,0)+-- TODO after we drop 8.8: save the distinction between => and ->+coreToType' (FunTy _ ty1 ty2)             = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2+#else coreToType' (FunTy ty1 ty2)             = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2+#endif coreToType' (LitTy tyLit)    = return $ C.LitTy (coreToTyLit tyLit) coreToType' (AppTy ty1 ty2)  = C.AppTy <$> coreToType ty1 <*> coreToType' ty2 coreToType' t@(CastTy _ _)   = error ("Cannot handle CastTy " ++ showPpr unsafeGlobalDynFlags t)
src-ghc/Clash/GHC/GenerateBindings.hs view
@@ -24,7 +24,6 @@ import qualified Data.IntMap.Strict      as IMS import qualified Data.HashMap.Strict     as HashMap import           Data.List               (isPrefixOf)-import           Data.List.Extra         (indexMaybe) import qualified Data.Text               as Text import qualified Data.Time.Clock         as Clock @@ -69,6 +68,12 @@ import           Clash.Unique   (listToUniqMap, lookupUniqMap, mapUniqMap, unionUniqMap, uniqMapToUniqSet) import           Clash.Util              (reportTimeDiff)++-- | Safe indexing, returns a 'Nothing' if the index does not exist+indexMaybe :: [a] -> Int -> Maybe a+indexMaybe [] _     = Nothing+indexMaybe (x:_)  0 = Just x+indexMaybe (_:xs) n = indexMaybe xs (n-1)  generateBindings   :: GHC.OverridingBool
src-ghc/Clash/GHC/LoadInterfaceFiles.hs view
@@ -6,12 +6,17 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}  module Clash.GHC.LoadInterfaceFiles   ( loadExternalExprs-  , unresolvedPrimitives+  , loadExternalBinders+  , getUnresolvedPrimitives+  , LoadedBinders(..)+  , mergeLoadedBinders+  , emptyLb   ) where @@ -19,7 +24,6 @@ import           Control.Monad.IO.Class      (MonadIO (..)) import qualified Data.ByteString.Lazy.UTF8   as BLU import qualified Data.ByteString.Lazy        as BL-import           Data.Either                 (partitionEithers) import           Data.List                   (elemIndex, foldl', partition) import qualified Data.Text                   as Text import           Data.Maybe                  (isJust, isNothing,@@ -64,6 +68,38 @@ import           Clash.GHC.GHC2Core                  (qualifiedNameString') import           Clash.Util                          (curLoc) +-- | Data structure tracking loaded binders (and their related data)+data LoadedBinders = LoadedBinders+  { lbBinders :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]+  -- ^ Binder + expression it's binding+  , lbClassOps :: [(CoreSyn.CoreBndr, Int)]+  -- ^ Type class dict projection functions+  , lbUnlocatable :: [CoreSyn.CoreBndr]+  -- ^ Binders with missing unfoldings+  , lbPrims :: [Either UnresolvedPrimitive FilePath]+  -- ^ Primitives; either an primitive data structure or a path to a directory+  -- containing json files+  , lbReprs :: [DataRepr']+  -- ^ Custom data representations+  }++mergeLoadedBinders :: [LoadedBinders] -> LoadedBinders+mergeLoadedBinders lbs =+  LoadedBinders {+    lbBinders=concat (map lbBinders lbs)+  , lbClassOps=concat (map lbClassOps lbs)+  , lbUnlocatable=concat (map lbUnlocatable lbs)+  , lbPrims=concat (map lbPrims lbs)+  , lbReprs=concat (map lbReprs lbs)+  }++emptyLb :: LoadedBinders+emptyLb = LoadedBinders [] [] [] [] []++collectLbBinders :: LoadedBinders -> [CoreSyn.CoreBndr]+collectLbBinders LoadedBinders{lbBinders, lbUnlocatable, lbClassOps} =+  concat [map fst lbBinders, lbUnlocatable, map fst lbClassOps]+ runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a runIfl modName action = do   hscEnv <- GHC.getSession@@ -90,86 +126,85 @@                                            ]                          in traceIf True msg' (return Nothing) +loadExternalBinders+  :: GHC.GhcMonad m+  => HDL+  -> [CoreSyn.CoreBndr]+  -> m LoadedBinders+loadExternalBinders hdl bndrs = do+  loaded <- mergeLoadedBinders <$> mapM (loadExprFromIface hdl) bndrs+  fst <$>+    loadExternalExprs'+      hdl+      loaded+      (UniqSet.mkUniqSet (collectLbBinders loaded))+      (map snd (lbBinders loaded))+ loadExternalExprs   :: GHC.GhcMonad m   => HDL   -> UniqSet.UniqSet CoreSyn.CoreBndr   -> [CoreSyn.CoreBind]-  -> m ( [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)] -- Binders-       , [(CoreSyn.CoreBndr,Int)]              -- Class Ops-       , [CoreSyn.CoreBndr]                    -- Unlocatable-       , [Either UnresolvedPrimitive FilePath]-       , [DataRepr']-       )-loadExternalExprs hdl = go [] [] [] [] []+  -> m LoadedBinders+loadExternalExprs hdl = go emptyLb   where-    go locatedExprs clsOps unlocated pFP reprs _ [] =-      return (locatedExprs,clsOps,unlocated,pFP,reprs)--    go locatedExprs clsOps unlocated pFP reprs visited (CoreSyn.NonRec _ e:bs) = do-      (locatedExprs',clsOps',unlocated',pFP',reprs',visited') <--        go' locatedExprs clsOps unlocated pFP reprs visited [e]-      go locatedExprs' clsOps' unlocated' pFP' reprs' visited' bs--    go locatedExprs clsOps unlocated pFP reprs visited (CoreSyn.Rec bs:bs') = do-      (locatedExprs',clsOps',unlocated',pFP',reprs',visited') <--        go' locatedExprs clsOps unlocated pFP reprs visited (map snd bs)-      go locatedExprs' clsOps' unlocated' pFP' reprs' visited' bs'--    go' locatedExprs clsOps unlocated pFP reprs visited [] =-      return (locatedExprs,clsOps,unlocated,pFP,reprs,visited)--    go' locatedExprs clsOps unlocated pFP reprs visited (e:es) = do-      let fvs = CoreFVs.exprSomeFreeVarsList-                  (\v -> Var.isId v &&-                         isNothing (Id.isDataConId_maybe v) &&-                         not (v `UniqSet.elementOfUniqSet` visited)-                  ) e+    go loaded _ [] =+      return loaded+    go loaded0 visited0 (CoreSyn.NonRec _ e:bs) = do+      (loaded1, visited1) <- loadExternalExprs' hdl loaded0 visited0 [e]+      go loaded1 visited1 bs+    go loaded0 visited0 (CoreSyn.Rec bs:bs') = do+      (loaded1, visited1) <- loadExternalExprs' hdl loaded0 visited0 (map snd bs)+      go loaded1 visited1 bs' -          (clsOps',fvs') = partition (isJust . Id.isClassOpId_maybe) fvs+-- | Used by entry points: 'loadExternalExprs', 'loadExternalBinders'+loadExternalExprs'+  :: GHC.GhcMonad m+  => HDL+  -> LoadedBinders+  -> UniqSet.UniqSet CoreSyn.CoreBndr+  -> [CoreSyn.CoreExpr]+  -> m ( LoadedBinders, UniqSet.UniqSet CoreSyn.CoreBndr)+loadExternalExprs' _hdl loaded visited [] =+  return (loaded, visited)+loadExternalExprs' hdl loaded0 visited0 (e:es) = do+  let fvs = CoreFVs.exprSomeFreeVarsList+              (\v -> Var.isId v &&+                     isNothing (Id.isDataConId_maybe v) &&+                     not (v `UniqSet.elementOfUniqSet` visited0)+              ) e -          clsOps'' = map-            ( \v -> flip (maybe (error $ $(curLoc) ++ "Not a class op")) (Id.isClassOpId_maybe v) $ \c ->-                let clsIds = Class.classAllSelIds c-                in  maybe (error $ $(curLoc) ++ "Index not found")-                          (v,)-                          (elemIndex v clsIds)-            ) clsOps'+      (clsOps',fvs') = partition (isJust . Id.isClassOpId_maybe) fvs -      (locatedAndUnlocated, pFP', reprs') <- unzip3 <$> mapM (loadExprFromIface hdl) fvs'-      let (locatedExprs', unlocated') = partitionEithers locatedAndUnlocated+      clsOps'' = map+        ( \v -> flip (maybe (error $ $(curLoc) ++ "Not a class op")) (Id.isClassOpId_maybe v) $ \c ->+            let clsIds = Class.classAllSelIds c+            in  maybe (error $ $(curLoc) ++ "Index not found")+                      (v,)+                      (elemIndex v clsIds)+        ) clsOps' -      let visited' = foldl' UniqSet.addListToUniqSet visited-                       [ map fst locatedExprs'-                       , unlocated'-                       , clsOps'-                       ]+  loaded1 <- mergeLoadedBinders <$> mapM (loadExprFromIface hdl) fvs' -      go' (locatedExprs'++locatedExprs)-          (clsOps''++clsOps)-          (unlocated'++unlocated)-          (concat pFP'++pFP)-          (concat reprs'++reprs)-          visited'-          (es ++ map snd locatedExprs')+  loadExternalExprs'+    hdl+    (mergeLoadedBinders [loaded0, loaded1, emptyLb{lbClassOps=clsOps''}])+    (foldl' UniqSet.addListToUniqSet visited0 [collectLbBinders loaded1, clsOps'])+    (es ++ map snd (lbBinders loaded1)) -loadExprFromIface ::-  GHC.GhcMonad m+loadExprFromIface+  :: GHC.GhcMonad m   => HDL   -> CoreSyn.CoreBndr-  -> m (Either-          (CoreSyn.CoreBndr,CoreSyn.CoreExpr) -- Located-          CoreSyn.CoreBndr                    -- Unlocated-       ,[Either UnresolvedPrimitive FilePath]-       ,[DataRepr']-       )+  -> m LoadedBinders loadExprFromIface hdl bndr = do   let moduleM = Name.nameModule_maybe $ Var.varName bndr   case moduleM of     Just nameMod -> runIfl nameMod $ do       ifaceM <- loadIface nameMod       case ifaceM of-        Nothing    -> return (Right bndr,[],[])+        Nothing ->+          return (emptyLb{lbUnlocatable=[bndr]})         Just iface -> do           let decls = map snd (GHC.mi_decls iface)           let nameFun = GHC.getOccName $ Var.varName bndr@@ -177,12 +212,16 @@           anns <- TcIface.tcIfaceAnnotations (GHC.mi_anns iface)           primFPs   <- loadPrimitiveAnnotations hdl anns           let reprs  = loadCustomReprAnnotations anns+              lb     = emptyLb{lbPrims=primFPs, lbReprs=reprs}           case declM of             [namedDecl] -> do               tyThing <- loadDecl namedDecl-              return (loadExprFromTyThing bndr tyThing,primFPs,reprs)-            _ -> return (Right bndr,primFPs,reprs)-    Nothing -> return (Right bndr,[],[])+              case loadExprFromTyThing bndr tyThing of+                Left bndr1 -> return (lb{lbBinders=[bndr1]})+                Right unloc -> return (lb{lbUnlocatable=[unloc]})+            _ -> return (lb{lbUnlocatable=[bndr]})+    Nothing ->+      return (emptyLb{lbUnlocatable=[bndr]})   loadCustomReprAnnotations@@ -219,7 +258,7 @@   -> [Annotations.Annotation]   -> m [Either UnresolvedPrimitive FilePath] loadPrimitiveAnnotations hdl anns =-  concat <$> mapM (unresolvedPrimitives hdl) prims+  concat <$> mapM (getUnresolvedPrimitives hdl) prims   where     prims = mapMaybe filterPrim anns     filterPrim (Annotations.Annotation target value) =@@ -228,12 +267,12 @@       GhcPlugins.fromSerialized         (GhcPlugins.deserializeWithData :: [Word8] -> Primitive) -unresolvedPrimitives+getUnresolvedPrimitives   :: MonadIO m   => HDL   -> (Annotations.CoreAnnTarget, Primitive)   -> m ([Either UnresolvedPrimitive FilePath])-unresolvedPrimitives hdl targetPrim =+getUnresolvedPrimitives hdl targetPrim =   case targetPrim of     (_, Primitive hdls fp) | hdl `elem` hdls -> pure [Right fp]
src-ghc/Clash/GHC/LoadModules.hs view
@@ -8,9 +8,10 @@  {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}  module Clash.GHC.LoadModules   ( loadModules@@ -33,7 +34,8 @@ import qualified Clash.Util.Interpolate          as I import           Control.Arrow                   (first, second) import           Control.DeepSeq                 (deepseq)-import           Control.Exception               (throw)+import           Control.Exception               (SomeException, throw)+import           Control.Monad                   (forM) #if MIN_VERSION_ghc(8,6,0) import           Control.Exception               (throwIO) #endif@@ -43,10 +45,11 @@ import           Data.Data                       (Data) import           Data.Typeable                   (Typeable) import           Data.List                       (foldl', nub)-import           Data.Maybe                      (catMaybes, listToMaybe)+import           Data.Maybe                      (catMaybes, listToMaybe, fromMaybe) import qualified Data.Text                       as Text import qualified Data.Time.Clock                 as Clock import           Language.Haskell.TH.Syntax      (lift)+import           GHC.Stack                       (HasCallStack)  #ifdef USE_GHC_PATHS import           GHC.Paths                       (libdir)@@ -68,6 +71,7 @@ #endif import           DynFlags                        (GeneralFlag (..)) import qualified DynFlags+import qualified Exception import qualified GHC import qualified HscMain import qualified HscTypes@@ -92,7 +96,9 @@  -- Internal Modules import           Clash.GHC.GHC2Core                           (modNameM, qualifiedNameString')-import           Clash.GHC.LoadInterfaceFiles                 (loadExternalExprs, unresolvedPrimitives)+import           Clash.GHC.LoadInterfaceFiles+  (loadExternalExprs, getUnresolvedPrimitives, loadExternalBinders,+   LoadedBinders(..)) import           Clash.GHCi.Common                            (checkMonoLocalBindsMod) import           Clash.Util                                   (curLoc, noSrcSpan, reportTimeDiff                                                               ,wantedLanguageExtensions, unwantedLanguageExtensions)@@ -128,6 +134,178 @@      return (output, exitCode) #endif +-- | Search databases for given module+loadExternalModule+  :: (HasCallStack, GHC.GhcMonad m)+  => HDL+  -> String+  -- ^ Module name. Can either be a filepath pointing to a .hs file, or a+  -- qualified module name (example: "Data.List").+  -> m (Either+          SomeException+          ( [CoreSyn.CoreBndr]                     -- Root binders+          , FamInstEnv.FamInstEnv                  -- Local type family instances+          , GHC.ModuleName                         -- Module name+          , LoadedBinders+          , [CoreSyn.CoreBind]                     -- All bindings+          ) )+loadExternalModule hdl modName0 = Exception.gtry $ do+  let modName1 = GHC.mkModuleName modName0+  foundMod <- GHC.findModule modName1 Nothing+  let errMsg = "Internal error: found  module, but could not load it"+  modInfo <- fromMaybe (error errMsg) <$> (GHC.getModuleInfo foundMod)+  tyThings <- catMaybes <$> mapM GHC.lookupGlobalName (GHC.modInfoExports modInfo)+  let rootIds = [id_ | GHC.AnId id_ <- tyThings]+  loaded <- loadExternalBinders hdl rootIds+  let allBinders = makeRecursiveGroups (lbBinders loaded)+  return (rootIds, FamInstEnv.emptyFamInstEnv, modName1, loaded, allBinders)++setupGhc+  :: GHC.GhcMonad m+  => OverridingBool+  -> Maybe GHC.DynFlags+  -> [FilePath]+  -> m ()+setupGhc useColor dflagsM idirs = do+  dflags <-+    case dflagsM of+      Just df -> return df+      Nothing -> do+#if MIN_VERSION_ghc(8,6,0)+        -- Make sure we read the .ghc environment files+        df <- do+          df <- GHC.getSessionDynFlags+          _ <- GHC.setSessionDynFlags df {DynFlags.pkgDatabase = Nothing}+          GHC.getSessionDynFlags+#else+        df <- GHC.getSessionDynFlags+#endif+        let df1 = setWantedLanguageExtensions df+            ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+            ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+            ghcTyLitKNPlugin   = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+            dfPlug = df1 { DynFlags.pluginModNames = nub $+                                ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+                                ghcTyLitKNPlugin : DynFlags.pluginModNames df1+                           , DynFlags.useColor = useColor+                           , DynFlags.importPaths = idirs+                           }+        return dfPlug++  let dflags1 = dflags+                  { DynFlags.optLevel = 2+                  , DynFlags.ghcMode  = GHC.CompManager+                  , DynFlags.ghcLink  = GHC.LinkInMemory+                  , DynFlags.hscTarget+                      = if DynFlags.rtsIsProfiled+                           then DynFlags.HscNothing+                           else DynFlags.defaultObjectTarget $+#if !MIN_VERSION_ghc(8,10,0)+                                  DynFlags.targetPlatform+#endif+                                    dflags+                  , DynFlags.reductionDepth = 1000+                  }+  let dflags2 = unwantedOptimizationFlags dflags1+      ghcDynamic = case lookup "GHC Dynamic" (DynFlags.compilerInfo dflags) of+                    Just "YES" -> True+                    _          -> False+      dflags3 = if ghcDynamic then DynFlags.gopt_set dflags2 DynFlags.Opt_BuildDynamicToo+                              else dflags2+#if MIN_VERSION_ghc(8,6,0)+  hscenv <- GHC.getSession+  dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3)+  _ <- GHC.setSessionDynFlags dflags4+#else+  _ <- GHC.setSessionDynFlags dflags3+#endif++  return ()++-- | Load a module from a Haskell file. Function does NOT look in currently+-- loaded modules.+loadLocalModule+  :: GHC.GhcMonad m+  => HDL+  -> String+  -- ^ Module name. Can either be a filepath pointing to a .hs file, or a+  -- qualified module name (example: "Data.List").+  -> m ( [CoreSyn.CoreBndr]                     -- Root binders+       , FamInstEnv.FamInstEnv                  -- Local type family instances+       , GHC.ModuleName                         -- Module name+       , LoadedBinders+       , [CoreSyn.CoreBind]                     -- All bindings+       )+loadLocalModule hdl modName = do+  target <- GHC.guessTarget modName Nothing+  GHC.setTargets [target]+  modGraph <- GHC.depanal [] False+#if MIN_VERSION_ghc(8,4,1)+  let modGraph' = GHC.mapMG disableOptimizationsFlags modGraph+#else+  let modGraph' = map disableOptimizationsFlags modGraph+#endif+      -- 'topSortModuleGraph' ensures that modGraph2, and hence tidiedMods+      -- are in topological order, i.e. the root module is last.+      modGraph2 = Digraph.flattenSCCs (GHC.topSortModuleGraph True modGraph' Nothing)++  liftIO $ mapM_ checkMonoLocalBindsMod modGraph2++  tidiedMods <- forM modGraph2 $ \m -> do+    oldDFlags <- GHC.getSessionDynFlags+    pMod  <- parseModule m+    _ <- GHC.setSessionDynFlags (GHC.ms_hspp_opts (GHC.pm_mod_summary pMod))+    tcMod <- GHC.typecheckModule (removeStrictnessAnnotations pMod)++    -- The purpose of the home package table (HPT) is to track+    -- the already compiled modules, so subsequent modules can+    -- rely/use those compilation results+    --+    -- We need to update the home package table (HPT) ourselves+    -- as we can no longer depend on 'GHC.load' to create a+    -- proper HPT.+    --+    -- The reason we have to cannot rely on 'GHC.load' is that+    -- it runs the rename/type-checker, which we also run in+    -- the code above. This would mean that the renamer/type-checker+    -- is run twice, which in turn means that template haskell+    -- splices are run twice.+    --+    -- Given that TH splices can do non-trivial computation and I/O,+    -- running TH twice must be avoid.+    tcMod' <- GHC.loadModule tcMod+    dsMod <- fmap GHC.coreModule $ GHC.desugarModule tcMod'+    hsc_env <- GHC.getSession+#if MIN_VERSION_ghc(8,4,1)+    simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env [] dsMod+#else+    simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod+#endif+    checkForInvalidPrelude simpl_guts+    (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env simpl_guts+    let pgm        = HscTypes.cg_binds tidy_guts+    let modFamInstEnv = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcMod+    _ <- GHC.setSessionDynFlags oldDFlags+    return (pgm,modFamInstEnv)++  let (binders,modFamInstEnvs) = unzip tidiedMods+      binderIds                = map fst (CoreSyn.flattenBinds (concat binders))+      plusFamInst f1 f2        = FamInstEnv.extendFamInstEnvList f1 (FamInstEnv.famInstEnvElts f2)+      modFamInstEnvs'          = foldl' plusFamInst FamInstEnv.emptyFamInstEnv modFamInstEnvs+      rootModule               = GHC.ms_mod_name . last $ modGraph2++  -- Because tidiedMods is in topological order, binders is also, and hence+  -- the binders belonging to the "root" module are the last binders+  let rootIds = map fst . CoreSyn.flattenBinds $ last binders+  loaded0 <- loadExternalExprs hdl (UniqSet.mkUniqSet binderIds) (concat binders)++  -- Find local primitive annotations+  localPrims <- findPrimitiveAnnotations hdl binderIds+  let loaded1 = loaded0{lbPrims=lbPrims loaded0 ++ localPrims}++  let allBinders = concat binders ++ makeRecursiveGroups (lbBinders loaded0)+  pure (rootIds, modFamInstEnvs', rootModule, loaded1, allBinders)+ loadModules   :: OverridingBool   -- ^ Use color@@ -154,151 +332,55 @@   libDir <- MonadUtils.liftIO ghcLibDir   startTime <- Clock.getCurrentTime   GHC.runGhc (Just libDir) $ do-    dflags <- case dflagsM of-                Just df -> return df-                Nothing -> do-#if MIN_VERSION_ghc(8,6,0)-                  -- Make sure we read the .ghc environment files-                  df <- do { df <- GHC.getSessionDynFlags-                           ; _ <- GHC.setSessionDynFlags df {DynFlags.pkgDatabase = Nothing}-                           ; GHC.getSessionDynFlags-                           }-#else-                  df <- GHC.getSessionDynFlags-#endif-                  let df1 = setWantedLanguageExtensions df-                  let ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"-                      ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"-                      ghcTyLitKNPlugin   = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"-                  let dfPlug = df1 { DynFlags.pluginModNames = nub $-                                          ghcTyLitNormPlugin : ghcTyLitExtrPlugin :-                                          ghcTyLitKNPlugin : DynFlags.pluginModNames df1-                                     , DynFlags.useColor = useColor-                                     , DynFlags.importPaths = idirs-                                     }-                  return dfPlug--    let dflags1 = dflags-                    { DynFlags.optLevel = 2-                    , DynFlags.ghcMode  = GHC.CompManager-                    , DynFlags.ghcLink  = GHC.LinkInMemory-                    , DynFlags.hscTarget-                        = if DynFlags.rtsIsProfiled-                             then DynFlags.HscNothing-                             else DynFlags.defaultObjectTarget-                                    (DynFlags.targetPlatform dflags)-                    , DynFlags.reductionDepth = 1000-                    }-    let dflags2 = unwantedOptimizationFlags dflags1-    let ghcDynamic = case lookup "GHC Dynamic" (DynFlags.compilerInfo dflags) of-                      Just "YES" -> True-                      _          -> False-    let dflags3 = if ghcDynamic then DynFlags.gopt_set dflags2 DynFlags.Opt_BuildDynamicToo-                                else dflags2-#if MIN_VERSION_ghc(8,6,0)-    hscenv <- GHC.getSession-    dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3)-    _ <- GHC.setSessionDynFlags dflags4-#else-    _ <- GHC.setSessionDynFlags dflags3-#endif-    target <- GHC.guessTarget modName Nothing-    GHC.setTargets [target]-    modGraph <- GHC.depanal [] False-#if MIN_VERSION_ghc(8,4,1)-    let modGraph' = GHC.mapMG disableOptimizationsFlags modGraph-#else-    let modGraph' = map disableOptimizationsFlags modGraph-#endif-        -- 'topSortModuleGraph' ensures that modGraph2, and hence tidiedMods-        -- are in topological order, i.e. the root module is last.-        modGraph2 = Digraph.flattenSCCs (GHC.topSortModuleGraph True modGraph' Nothing)-    tidiedMods <- mapM (\m -> do { oldDFlags <- GHC.getSessionDynFlags-                                 ; pMod  <- parseModule m-                                 ; _ <- GHC.setSessionDynFlags (GHC.ms_hspp_opts (GHC.pm_mod_summary pMod))-                                 ; tcMod <- GHC.typecheckModule (removeStrictnessAnnotations pMod)-                                 -- The purpose of the home package table (HPT) is to track-                                 -- the already compiled modules, so subsequent modules can-                                 -- rely/use those compilation results-                                 ---                                 -- We need to update the home package table (HPT) ourselves-                                 -- as we can no longer depend on 'GHC.load' to create a-                                 -- proper HPT.-                                 ---                                 -- The reason we have to cannot rely on 'GHC.load' is that-                                 -- it runs the rename/type-checker, which we also run in-                                 -- the code above. This would mean that the renamer/type-checker-                                 -- is run twice, which in turn means that template haskell-                                 -- splices are run twice.-                                 ---                                 -- Given that TH splices can do non-trivial computation and I/O,-                                 -- running TH twice must be avoid.-                                 ; tcMod' <- GHC.loadModule tcMod-                                 ; dsMod <- fmap GHC.coreModule $ GHC.desugarModule tcMod'-                                 ; hsc_env <- GHC.getSession-#if MIN_VERSION_ghc(8,4,1)-                                 ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env [] dsMod-#else-                                 ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod-#endif-                                 ; checkForInvalidPrelude simpl_guts-                                 ; (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env simpl_guts-                                 ; let pgm        = HscTypes.cg_binds tidy_guts-                                 ; let modFamInstEnv = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcMod-                                 ; _ <- GHC.setSessionDynFlags oldDFlags-                                 ; return (pgm,modFamInstEnv)-                                 }-                         ) modGraph2+    -- 'mainFunIs' is set to Nothing due to issue #1304:+    -- https://github.com/clash-lang/clash-compiler/issues/1304+    setupGhc useColor ((\d -> d{GHC.mainFunIs=Nothing}) <$> dflagsM) idirs+    -- TODO: We currently load the transitive closure of _all_ bindings found+    -- TODO: in the top module. This is wasteful if one or more binders don't+    -- TODO: contribute to any top entities. This effect is worsened when using+    -- TODO: -main-is, which only synthesizes a single top entity (and all its+    -- TODO: dependencies).+    (rootIds, modFamInstEnvs, rootModule, LoadedBinders{..}, allBinders) <-+      -- We need to try and load external modules first, because we can't+      -- recover from errors in 'loadLocalModule'.+      loadExternalModule hdl modName >>= \case+        Left _loadExternalErr -> loadLocalModule hdl modName+        Right res -> pure res -    let (binders,modFamInstEnvs) = unzip tidiedMods-        bindersC                 = concat binders-        binderIds                = map fst (CoreSyn.flattenBinds bindersC)-        plusFamInst f1 f2        = FamInstEnv.extendFamInstEnvList f1 (FamInstEnv.famInstEnvElts f2)-        modFamInstEnvs'          = foldl' plusFamInst FamInstEnv.emptyFamInstEnv modFamInstEnvs+    let allBinderIds = map fst (CoreSyn.flattenBinds allBinders) -    modTime <- startTime `deepseq` length binderIds `deepseq` MonadUtils.liftIO Clock.getCurrentTime+    modTime <- startTime `deepseq` length allBinderIds `seq` MonadUtils.liftIO Clock.getCurrentTime     let modStartDiff = reportTimeDiff modTime startTime     MonadUtils.liftIO $ putStrLn $ "GHC: Parsing and optimising modules took: " ++ modStartDiff -    (externalBndrs,clsOps,unlocatable,unresolvedPrimitives0,reprs) <--      loadExternalExprs hdl (UniqSet.mkUniqSet binderIds) bindersC--    let externalBndrIds = map fst externalBndrs-    let allBinderIds = externalBndrIds ++ binderIds--    extTime <- modTime `deepseq` length unlocatable `deepseq` MonadUtils.liftIO Clock.getCurrentTime+    extTime <- modTime `deepseq` length lbUnlocatable `deepseq` MonadUtils.liftIO Clock.getCurrentTime     let extModDiff = reportTimeDiff extTime modTime     MonadUtils.liftIO $ putStrLn $ "GHC: Loading external modules from interface files took: " ++ extModDiff -    -- Find local primitive annotations-    unresolvedPrimitives1 <- findPrimitiveAnnotations hdl binderIds-+    -- Get type family instances: accumulated by GhcMonad during+    -- 'loadExternalBinders' / 'loadExternalExprs'     hscEnv <- GHC.getSession #if MIN_VERSION_ghc(8,6,0)-    famInstEnvs <- do { (msgs,m) <- TcRnMonad.liftIO $ TcRnMonad.initTcInteractive hscEnv FamInst.tcGetFamInstEnvs-                      ; case m of-                          Nothing -> TcRnMonad.liftIO $ throwIO (HscTypes.mkSrcErr (snd msgs))-                          Just x  -> return x-                      }+    famInstEnvs <- do+      (msgs, m) <- TcRnMonad.liftIO $ TcRnMonad.initTcInteractive hscEnv FamInst.tcGetFamInstEnvs+      case m of+        Nothing -> TcRnMonad.liftIO $ throwIO (HscTypes.mkSrcErr (snd msgs))+        Just x  -> return x #else     famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs #endif      -- Because tidiedMods is in topological order, binders is also, and hence-    -- the binders belonging to the "root" module are the last binders-    let rootModule = GHC.ms_mod_name . last $ modGraph2-        rootIds    = map fst . CoreSyn.flattenBinds $ last binders--    -- Because tidiedMods is in topological order, binders is also, and hence     -- allSyn is in topological order. This means that the "root" 'topEntity'     -- will be compiled last.-    allSyn     <- map (second Just) <$> findSynthesizeAnnotations binderIds+    allSyn     <- map (second Just) <$> findSynthesizeAnnotations allBinderIds     topSyn     <- map (second Just) <$> findSynthesizeAnnotations rootIds-    benchAnn   <- findTestBenchAnnotations binderIds+    benchAnn   <- findTestBenchAnnotations rootIds     reprs'     <- findCustomReprAnnotations     primGuards <- findPrimitiveGuardAnnotations allBinderIds-    let varNameString = OccName.occNameString . Name.nameOccName . Var.varName-        topEntities = filter ((== "topEntity") . varNameString) rootIds+    let topEntityName = fromMaybe "topEntity" (GHC.mainFunIs =<< dflagsM)+        varNameString = OccName.occNameString . Name.nameOccName . Var.varName+        topEntities = filter ((==topEntityName) . varNameString) rootIds         benches     = filter ((== "testBench") . varNameString) rootIds         mergeBench (x,y) = (x,y,lookup x benchAnn)         allSyn'     = map mergeBench allSyn@@ -307,14 +389,20 @@       case (topEntities, topSyn) of         ([], []) ->           let modName1 = Outputable.showSDocUnsafe (ppr rootModule) in-          Panic.pgmError [I.i|-            No top-level function called 'topEntity' found, nor a function with-            a 'Synthesize' annotation in module #{modName1}. Did you forget to-            export them?+          if topEntityName /= "topEntity" then+            Panic.pgmError [I.i|+              No top-level function called '#{topEntityName}' found. Did you+              forget to export it?+            |]+          else+            Panic.pgmError [I.i|+              No top-level function called 'topEntity' found, nor a function with+              a 'Synthesize' annotation in module #{modName1}. Did you forget to+              export them? -            For more information on 'Synthesize' annotations, check out the-            documentation of "Clash.Annotations.TopEntity".-          |]+              For more information on 'Synthesize' annotations, check out the+              documentation of "Clash.Annotations.TopEntity".+            |]         ([], _) ->           return allSyn'         ([x], _) ->@@ -328,27 +416,25 @@         (_, _) ->           Panic.pgmError $ $(curLoc) ++ "Multiple 'topEntities' found." -    let unresolvedPrimitives2 = unresolvedPrimitives0 ++ unresolvedPrimitives1-        reprs1 = reprs ++ reprs'+    let reprs1 = lbReprs ++ reprs'      annTime <-       extTime         `deepseq` length topEntities'-        `deepseq` unresolvedPrimitives2+        `deepseq` lbPrims         `deepseq` reprs1         `deepseq` primGuards         `deepseq` MonadUtils.liftIO Clock.getCurrentTime      let annExtDiff = reportTimeDiff annTime extTime     MonadUtils.liftIO $ putStrLn $ "GHC: Parsing annotations took: " ++ annExtDiff-    MonadUtils.liftIO $ mapM_ checkMonoLocalBindsMod modGraph2 -    return ( bindersC ++ makeRecursiveGroups externalBndrs-           , clsOps-           , unlocatable-           , (fst famInstEnvs, modFamInstEnvs')+    return ( allBinders+           , lbClassOps+           , lbUnlocatable+           , (fst famInstEnvs, modFamInstEnvs)            , topEntities'-           , unresolvedPrimitives2+           , lbPrims            , reprs1            , primGuards            )@@ -525,7 +611,7 @@   anns <- findAnnotationsByTargets targets    concat <$>-    mapM (unresolvedPrimitives hdl)+    mapM (getUnresolvedPrimitives hdl)     (concat $ zipWith (\t -> map ((,) t)) targets anns)  parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule