packages feed

clash-ghc 0.7.2 → 0.99

raw patch · 39 files changed

+17957/−8094 lines, 39 filesdep +concurrent-supplydep +ghc-primdep +integer-gmpdep −clash-systemverilogdep −clash-verilogdep −clash-vhdldep ~bifunctorsdep ~clash-libdep ~clash-prelude

Dependencies added: concurrent-supply, ghc-prim, integer-gmp, reflection

Dependencies removed: clash-systemverilog, clash-verilog, clash-vhdl

Dependency ranges changed: bifunctors, clash-lib, clash-prelude, ghc, ghc-boot, ghc-typelits-knownnat, ghci, lens

Files

CHANGELOG.md view
@@ -1,6 +1,20 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package -## 0.7.2 *April 25th 2017*+## 0.99 *March 31st 2018*+* New features:+  * Support for `clash-prelude-0.99`:+      * Explicit clock and reset arguments+      * Overhaul of `TopEntity` annotations+  * Hierarchies with multiple synthesisable boundaries by allowing more than one+    function in scope to have a `Synthesize` annotation.+    * Local caching of functions with a `Synthesize` annotation+  * `Bit` type is mapped to a HDL scalar type (e.g. `std_logic` in VHDL)+  * Improved name preservation+  * Zero-bit values are filtered out of the generated HDL+  * Improved compile-time computation+* Many bug fixes++## 0.7.2 * New features:   * Sum-of-product types: unused bits now "don't-care" [#212](https://github.com/clash-lang/clash-compiler/commit/fabf745793491ce3baf84ef0066b4ccf0753d503) * Fixes bugs:
LICENSE view
@@ -1,5 +1,6 @@ Copyright (c) 2012-2016, University of Twente,-              2017, QBayLogic+              2016-2017, Myrtle Software Ltd,+              2017     , QBayLogic, Google Inc. All rights reserved.  Redistribution and use in source and binary forms, with or without
cbits/PosixSource.h view
@@ -11,32 +11,44 @@  #include <ghcplatform.h> -#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)+/* We aim for C99 so we need to define following two defines in a consistent way+   with what POSIX/XOPEN provide for C99. Some OSes are particularly picky about+   the right versions defined here, e.g. Solaris+   We also settle on lowest version of POSIX/XOPEN needed for proper C99 support+   here which is POSIX.1-2001 compilation and Open Group Technical Standard,+   Issue 6 (XPG6). XPG6 itself is a result of the merge of X/Open and POSIX+   specification. It is also referred as IEEE Std. 1003.1-2001 or ISO/IEC+   9945:2002 or UNIX 03 and SUSv3.+   Please also see trac ticket #11757 for more information about switch+   to C99/C11.++   However, the use of `strnlen`, which is strictly speaking only available in+   IEEE Std 1003.1-2008 (XPG7), requires lifting the bounds, to be able to+   compile ghc on systems that are strict about enforcing the standard, e.g.+   Apples mobile platforms.++   Oracle's Solaris 11 supports only up to XPG6, hence the ifdef.+  */++#if defined(solaris2_HOST_OS) #define _POSIX_C_SOURCE 200112L #define _XOPEN_SOURCE   600 #else-#define _POSIX_SOURCE   1-#define _POSIX_C_SOURCE 199506L-#define _XOPEN_SOURCE   500-// FreeBSD takes a different approach to _ISOC99_SOURCE: on FreeBSD it-// means "I want *just* C99 things", whereas on GNU libc and Solaris-// it means "I also want C99 things".-//-// On both GNU libc and FreeBSD, _ISOC99_SOURCE is implied by-// _XOPEN_SOURCE==600, but on Solaris it is an error to omit it.-#define _ISOC99_SOURCE-// Defining __USE_MINGW_ANSI_STDIO is the most portable way to tell-// mingw that we want to use the standard %lld style format specifiers,-// rather than the Windows %I64d style-#define __USE_MINGW_ANSI_STDIO 1+#define _POSIX_C_SOURCE 200809L+#define _XOPEN_SOURCE   700 #endif -#if defined(darwin_HOST_OS)-/* If we don't define this the including sysctl breaks with things like-    /usr/include/bsm/audit.h:224:0:-         error: syntax error before 'u_char'-*/-#define _DARWIN_C_SOURCE 1+#if defined(mingw32_HOST_OS)+/* Without this gcc will warn about %ull and the like since some msvcrt versions+   do not support them. See+   https://sourceforge.net/p/mingw-w64/mailman/message/28557333/++   Note that this is implied by _POSIX_C_SOURCE in the msys2 toolchain that we+   now use. However, we retain this explicit #define to preserve the ability to+   bootstrap GHC with compilers still using msys (e.g. GHC 7.10.1 and 7.10.2).+   This can be removed in for GHC 8.4. See #12951.+  */+#define __USE_MINGW_ANSI_STDIO 1 #endif  #endif /* POSIXSOURCE_H */
cbits/hschooks.c view
@@ -5,11 +5,18 @@ */  #include "PosixSource.h"++/*+ * This should be linked against Rts.h from the compiler which is compiling us.+ * For instance, if we are compiling this file to produce the stage1 compiler,+ * we should use Rts.h from stage0.+ */ #include "Rts.h"  #include "HsFFI.h"  #include <string.h>+#include <stdbool.h>  #ifdef HAVE_UNISTD_H #include <unistd.h>@@ -33,7 +40,7 @@     // This helps particularly with large compiles, but didn't work     // very well with earlier GHCs because it caused large amounts of     // fragmentation.  See rts/sm/BlockAlloc.c:allocLargeChunk().-    RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue;+    RtsFlags.GcFlags.heapSizeSuggestionAuto = true;      RtsFlags.GcFlags.maxStkSize         = 512*1024*1024 / sizeof(W_); @@ -47,6 +54,8 @@ void StackOverflowHook (StgWord stack_size)    /* in bytes */ {-    fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K<size>' option to increase it.\n", (size_t)stack_size);+    fprintf(stderr,+            "GHC stack-space overflow: current limit is %zu bytes.\n"+            "Use the `-K<size>' option to increase it.\n",+            (size_t) stack_size); }-
clash-ghc.cabal view
@@ -1,5 +1,5 @@ Name:                 clash-ghc-Version:              0.7.2+Version:              0.99 Synopsis:             CAES Language for Synchronous Hardware Description:   CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -36,16 +36,18 @@ License-file:         LICENSE Author:               Christiaan Baaij Maintainer:           Christiaan Baaij <christiaan.baaij@gmail.com>-Copyright:            Copyright © 2012-2016, University of Twente, 2017 QBayLogic+Copyright:            Copyright © 2012-2016, University of Twente,+                                  2016-2017, Myrtle Software Ltd,+                                  2017     , QBayLogic, Google Inc. Category:             Hardware Build-type:           Simple  Extra-source-files:   README.md,                       CHANGELOG.md,                       LICENSE_GHC,-                       cbits/PosixSource.h,-                      src-bin/CLaSH/GHCi/HsVersions.h+                      src-bin/Clash/GHCi/HsVersions.h+                      src-bin-841/Clash/GHCi/HsVersions.h  Cabal-version:        >=1.10 @@ -54,21 +56,25 @@   location: https://github.com/clash-lang/clash-compiler.git  executable clash-  default-language:   Haskell2010   Main-Is:            src-ghc/Batch.hs   Build-Depends:      base, clash-ghc-  GHC-Options:        -Wall+  GHC-Options:        -Wall -dynamic+  extra-libraries:    pthread   default-language:   Haskell2010  executable clashi-  default-language:   Haskell2010   Main-Is:            src-ghc/Interactive.hs   Build-Depends:      base, clash-ghc-  GHC-Options:        -Wall+  GHC-Options:        -Wall -dynamic+  extra-libraries:    pthread   default-language:   Haskell2010  library-  HS-Source-Dirs:     src-ghc src-bin+  HS-Source-Dirs:     src-ghc+  if impl(ghc >= 8.4.1)+    HS-Source-Dirs:   src-bin-841+  else+    HS-Source-Dirs:   src-bin    default-language:   Haskell2010   GHC-Options:        -Wall -fno-warn-name-shadowing@@ -91,36 +97,36 @@    Build-Depends:      array                     >= 0.4      && < 0.6,                       base                      >= 4.3.1.0  && < 5,-                      bifunctors                >= 4.1.1    && < 5.5,+                      bifunctors                >= 4.1.1    && < 5.6,                       bytestring                >= 0.9      && < 0.11,                       containers                >= 0.5.4.0  && < 0.6,                       directory                 >= 1.2      && < 1.4,                       filepath                  >= 1.3      && < 1.5,-                      ghc                       >= 8.0.1    && < 8.2,+                      ghc                       >= 8.2.0    && < 8.6,                       process                   >= 1.2      && < 1.7,                       hashable                  >= 1.1.2.3  && < 1.3,                       haskeline                 >= 0.7.0.3  && < 0.8,-                      lens                      >= 4.0.5    && < 4.16,+                      lens                      >= 4.0.5    && < 4.17,                       mtl                       >= 2.1.1    && < 2.3,                       text                      >= 0.11.3.1 && < 1.3,                       transformers              >= 0.4.2    && < 0.6,                       unbound-generics          >= 0.1      && < 0.4,                       unordered-containers      >= 0.2.1.0  && < 0.3, -                      clash-lib                 >= 0.7.1    && < 0.8,-                      clash-systemverilog       >= 0.7.2    && < 0.8,-                      clash-vhdl                >= 0.7.2    && < 0.8,-                      clash-verilog             >= 0.7.2    && < 0.8,-                      clash-prelude             >= 0.11.2   && < 0.12,+                      clash-lib                 >= 0.7.1    && < 1.0,+                      clash-prelude             >= 0.11.2   && < 1.0,+                      concurrent-supply         >= 0.1.7    && < 0.2,                       ghc-typelits-extra        >= 0.1.3    && < 0.3,-                      ghc-typelits-knownnat     >= 0.1.2    && < 0.3,+                      ghc-typelits-knownnat     >= 0.1.2    && < 0.5,                       ghc-typelits-natnormalise >= 0.4.3    && < 0.6,                       deepseq                   >= 1.3.0.2  && < 1.5,-                       time                      >= 1.4.0.1  && < 1.9,-                      ghc-boot                  >= 8.0.1    && < 8.2,-                      ghci                      >= 8.0.1    && < 8.2,-                      uniplate                  >= 1.6.12   && < 1.8+                      ghc-boot                  >= 8.0.2    && < 8.6,+                      ghc-prim                  >= 0.3.1.0  && < 0.6,+                      ghci                      >= 8.2.0    && < 8.6,+                      uniplate                  >= 1.6.12   && < 1.8,+                      reflection                >= 2.1.2    && < 3.0,+                      integer-gmp               >= 1.0.1.0  && < 2.0    if os(windows)     Build-Depends:    Win32                     >= 2.3.1    && < 2.6@@ -130,17 +136,17 @@   Include-dirs:       cbits   C-Sources:          cbits/hschooks.c -  Exposed-Modules:    CLaSH.Main-  Other-Modules:      CLaSH.GHCi.UI-                      CLaSH.GHCi.UI.Info-                      CLaSH.GHCi.UI.Monad-                      CLaSH.GHCi.UI.Tags+  Exposed-Modules:    Clash.Main+  Other-Modules:      Clash.GHCi.UI+                      Clash.GHCi.UI.Info+                      Clash.GHCi.UI.Monad+                      Clash.GHCi.UI.Tags -                      CLaSH.GHC.CLaSHFlags-                      CLaSH.GHC.Evaluator-                      CLaSH.GHC.GenerateBindings-                      CLaSH.GHC.GHC2Core-                      CLaSH.GHC.LoadInterfaceFiles-                      CLaSH.GHC.LoadModules-                      CLaSH.GHC.NetlistTypes+                      Clash.GHC.ClashFlags+                      Clash.GHC.Evaluator+                      Clash.GHC.GenerateBindings+                      Clash.GHC.GHC2Core+                      Clash.GHC.LoadInterfaceFiles+                      Clash.GHC.LoadModules+                      Clash.GHC.NetlistTypes                       Paths_clash_ghc
+ src-bin-841/Clash/GHCi/HsVersions.h view
@@ -0,0 +1,65 @@+#pragma once++#if 0++IMPORTANT!  If you put extra tabs/spaces in these macro definitions,+you will screw up the layout where they are used in case expressions!++(This is cpp-dependent, of course)++#endif++/* Useful in the headers that we share with the RTS */+#define COMPILING_GHC 1++/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */+/* #include "ghc_boot_platform.h" */++/* Pull in the autoconf defines (HAVE_FOO), but don't include+ * ghcconfig.h, because that will include ghcplatform.h which has the+ * wrong platform settings for the compiler (it has the platform+ * settings for the target plat instead). */+/* #include "ghcautoconf.h" */++#define GLOBAL_VAR(name,value,ty)  \+{-# NOINLINE name #-};             \+name :: IORef (ty);                \+name = Util.global (value);++#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-};              \+name :: IORef (ty);                 \+name = Util.globalM (value);+++#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-};                                      \+name :: IORef (ty);                                         \+name = Util.sharedGlobal (value) (accessor);                \+foreign import ccall unsafe saccessor                       \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \+{-# NOINLINE name #-};                                         \+name :: IORef (ty);                                            \+name = Util.sharedGlobalM (value) (accessor);                  \+foreign import ccall unsafe saccessor                          \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));+++#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $++-- Examples:   Assuming   flagSet :: String -> m Bool+--+--    do { c   <- getChar; MASSERT( isUpper c ); ... }+--    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }+--    do { str <- getStr;  ASSERTM( flagSet str ); .. }+--    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }+--    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }+#define MASSERT(e)      ASSERT(e) return ()+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()+#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }+#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }
+ src-bin-841/Clash/GHCi/UI.hs view
@@ -0,0 +1,3901 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- 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, runDecls )+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,+             getModuleGraph, handleSourceError )+import HsImpExp+import HsSyn+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+                  setInteractivePrintName, hsc_dflags, msObjFilePath )+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 )++-- 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++-- 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, nub,+                   partition, sort, sortBy )+import qualified Data.Set as S+import Data.Maybe+import qualified Data.Map as M+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 )++-- 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.Netlist.BlackBox.Types (HdlSyn)+import           Clash.Util (clashLibVersion)+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+        availableCommands :: [Command],+        shortHelpText     :: String,+        fullHelpText      :: String,+        defPrompt         :: PromptFunction,+        defPromptCont     :: PromptFunction+    }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+    GhciSettings {+        availableCommands = ghciCommands opts,+        shortHelpText     = defShortHelpText,+        defPrompt         = default_prompt,+        defPromptCont     = default_prompt_cont,+        fullHelpText      = defFullHelpText+    }++ghciWelcomeMsg :: String+ghciWelcomeMsg = "CLaSHi, version " ++ Data.Version.showVersion Paths_clash_ghc.version +++                 " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion +++                 "):\nhttp://www.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),+  ("edit",      keepGoing' editFile,            completeFilename),+  ("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)+  ] ++ 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" +++  "   :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" +++  "   :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" +++  "   :!<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 breakpoint\n" +++  "   :delete *                   delete 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 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>" +++                     "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.+   dflags <- getDynFlags+   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)+               . (`xopt_unset` LangExt.MonomorphismRestriction)+               $ dflags+   GHC.setInteractiveDynFlags dflags'++   lastErrLocationsRef <- liftIO $ newIORef []+   progDynFlags <- GHC.getProgramDynFlags+   _ <- GHC.setProgramDynFlags $+      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }++   when (isNothing maybe_exprs) $ do+        -- Only for GHCi (not runghc and ghc -e):++        -- Turn buffering off for the compiled program's stdout/stderr+        turnOffBuffering_ nobuffering+        -- Turn buffering off for GHCi's stdout+        liftIO $ hFlush stdout+        liftIO $ hSetBuffering stdout NoBuffering+        -- We don't want the cmd line to buffer any input that might be+        -- intended for the program, so unbuffer stdin.+        liftIO $ hSetBuffering stdin NoBuffering+        liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+        -- On Unix, stdin will use the locale encoding.  The IO library+        -- doesn't do this on Windows (yet), so for now we use UTF-8,+        -- for consistency with GHC 6.10 and to make the tests work.+        liftIO $ hSetEncoding stdin utf8+#endif++   default_editor <- liftIO $ findEditor+   eval_wrapper <- mkEvalWrapper default_progname default_args+   let prelude_import = simpleImportDecl preludeModuleName+   startGHCi (runGHCi srcs maybe_exprs)+        GHCiState{ progname           = default_progname,+                   args               = default_args,+                   evalWrapper        = eval_wrapper,+                   prompt             = default_prompt,+                   prompt_cont        = default_prompt_cont,+                   stop               = default_stop,+                   editor             = default_editor,+                   options            = [],+                   -- 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             = [],+                   tickarrays         = emptyModuleEnv,+                   ghci_commands      = availableCommands config,+                   ghci_macros        = [],+                   last_command       = Nothing,+                   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 ()++resetLastErrorLocations :: GHCi ()+resetLastErrorLocations = do+    st <- getGHCiState+    liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: IORef [(FastString, Int)] ->  LogAction+ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do+    defaultLogAction 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++   current_dir = return (Just ".clashi")++   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++  dot_cfgs <- if ignore_dot_ghci then return [] else do+    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]+    liftIO $ filterM checkFileAndDirPerms dot_files+  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs++  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 $ (catMaybes mdot_cfgs) ++ arg_cfgs+    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.++  -- 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+            -- enter the interactive loop+            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+        Just exprs -> do+            -- just evaluate the expression we were given+            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 Trac #7962+                _ <- runCommands' hdle+                     (Just $ hdle (toException $ ExitFailure 1) >> return ())+                     (return Nothing)+                return ()++  -- and finally, exit+  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."++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 .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else.  I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "."  always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+  file_ok <- checkPerms file+  -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+  -- print some confusing and useless warnings in some cases (e.g. in+  -- travis). Note that we can't add a test for this, as all ghci tests should+  -- run with -ignore-dot-ghci, which means we never get here.+  if file_ok then checkPerms (getDirectory file) else return False+  where+  getDirectory f = case takeDirectory f of+    "" -> "."+    d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+  handleIO (\_ -> return False) $ do+    st <- getFileStatus file+    me <- getRealUserID+    let mode = System.Posix.fileMode st+        ok = (fileOwner st == me || fileOwner st == 0) &&+             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+             otherWriteMode /= mode `intersectFileModes` otherWriteMode+    unless ok $+      -- #8248: Improving warning to include a possible fix.+      putStrLn $ "*** WARNING: " ++ file +++                 " is writable by someone else, IGNORING!" +++                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+    return ok+#endif++incrementLineNo :: InputT GHCi ()+incrementLineNo = modifyGHCiState incLineNo+  where+    incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: Handle -> InputT GHCi (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 :: GHCi (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 = \_ _ -> do+    (context, modules_names, line) <- getInfoForPrompt++    let+        processString :: String -> GHCi SDoc+        processString ('%':'s':xs) =+            liftM2 (<>) (return modules_list) (processString xs)+            where+              modules_list = context <> modules_bit+              modules_bit = 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++    processString promptS++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 :: GHCi (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 :: Maybe String -> Bool -> GHCi ()+installInteractivePrint Nothing _  = return ()+installInteractivePrint (Just ipFun) exprmode = do+  ok <- trySuccess $ do+                (name:_) <- GHC.parseName ipFun+                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+                                      in he{hsc_IC = new_ic})+                return Succeeded++  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+             -> Maybe (GHCi ()) -- ^ Source error handler+             -> InputT GHCi (Maybe String)+             -> InputT GHCi (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  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $+             handleSourceError printErrorAndFail+               (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 (Maybe Bool)++    -- command+    doCommand stmt | (':' : cmd) <- removeSpaces stmt = do+      result <- specialCommand cmd+      case result of+        True -> return Nothing+        _    -> return $ Just True++    -- 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 $ Just True+            Just ml_stmt -> do+              -- temporarily compensate line-number for multi-line input+              result <- timeIt runAllocs $ lift $+                runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+              return $ Just (runSuccess result)+        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+          result <- timeIt runAllocs $ lift $+            runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+          return $ Just (runSuccess result)++    -- 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 :: String -> InputT GHCi (Maybe String)+                    -> InputT GHCi (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 :: [String] -> GHCi ()+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 :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt stmt step = do+  dflags <- GHC.getInteractiveDynFlags+  if | GHC.isStmt dflags stmt    -> run_stmt+     | GHC.isImport dflags stmt  -> 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 stmt -> throwGhcException+       (CmdLineError "error: expecting a single import declaration")+     -- Note: `GHC.isDecl` returns False on input like+     -- `data Infix a b = a :@: b; infixl 4 :@:`+     -- and should therefore not be used here.+     | otherwise                 -> run_decl++  where+    run_import = do+      addImportToContext stmt+      return (Just (GHC.ExecComplete (Right []) 0))++    run_decl =+        do _ <- liftIO $ tryIO $ hFlushAll stdin+           m_result <- GhciMonad.runDecls stmt+           case m_result of+               Nothing     -> return Nothing+               Just result ->+                 Just <$> afterRunStmt (const True)+                            (GHC.ExecComplete (Right result) 0)++    run_stmt =+        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.runStmt stmt step+           case m_result of+               Nothing     -> return Nothing+               Just result -> Just <$> afterRunStmt (const True) result++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi 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 ::+  Maybe GHC.BreakInfo -> GHCi (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) <- breaks st,+                                  breakModule loc == md,+                                  breakTick loc == nm ]++printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()+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 :: [Name] -> GHCi ()+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 :: Name -> GHCi ()+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 <- lift $ 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 :: String -> GHCi Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: String -> GHCi (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' :: String -> GHCi (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 `isPrefixOf`) . 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++getCurrentBreakSpan :: GHCi (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 :: GHCi (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 :: GHCi (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 :: GHCi () -> String -> GHCi ()+noArgs m "" = m+noArgs _ _  = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: String -> GHCi () -> GHCi ()+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 :: String -> GHCi ()+help _ = do+    txt <- long_help `fmap` getGHCiState+    liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: Bool -> String -> InputT GHCi ()+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 :: String -> GHCi ()+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 :: String -> GHCi ()+runRun s = case toCmdArgs s of+           Left err          -> liftIO (hPutStrLn stderr err)+           Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: [String] -> String -> GHCi ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++                                       show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: String -> InputT GHCi ()+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."+  GHC.setTargets []+  _ <- GHC.load LoadAllTargets+  lift $ 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) $+    lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+    handleSourceError (\e -> do GHC.printException e+                                return Failed) $ do+      act++-----------------------------------------------------------------------------+-- :edit++editFile :: String -> InputT GHCi ()+editFile str =+  do file <- if null str then lift 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 :: GHCi 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 :: Bool{-overwrite-} -> String -> GHCi ()+defineMacro _ (':':_) =+  liftIO $ putStrLn "macro name cannot start with a colon"+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+  if (not overwrite && macro_name `elem` defined)+        then throwGhcException (CmdLineError+                ("macro '" ++ macro_name ++ "' is already defined"))+        else do++  -- 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 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 :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool+runMacro fun s = do+  hsc_env <- GHC.getSession+  str <- liftIO $ evalStringToIOString hsc_env fun s+  enqueueCommands (lines str)+  return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: String -> GHCi ()+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 :: String -> GHCi ()+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 :: GHCi (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 body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: String -> InputT GHCi ()+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+++-----------------------------------------------------------------------------+-- :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 :: InputT GHCi a -> InputT GHCi 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 :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule fs = timeIt (const Nothing) (loadModule' fs)++-- | @:load@ command+loadModule_ :: [FilePath] -> InputT GHCi ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: [FilePath] -> InputT GHCi ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi 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.++  -- unload first+  _ <- GHC.abandonAll+  lift discardActiveBreakPoints+  GHC.setTargets []+  _ <- GHC.load LoadAllTargets++  GHC.setTargets targets+  doLoadAndCollectInfo False LoadAllTargets++-- | @:add@ command+addModule :: [FilePath] -> InputT GHCi ()+addModule files = do+  lift 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 :: Target -> InputT GHCi Bool+    checkTarget (Target (TargetModule m) _ _) = checkTargetModule m+    checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f++    checkTargetModule :: ModuleName -> InputT GHCi 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 :: [FilePath] -> InputT GHCi ()+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 :: String -> InputT GHCi ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+  where+    loadTargets | null m    = LoadAllTargets+                | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: String -> InputT GHCi ()+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 :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+  doCollectInfo <- lift (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 :: Bool -> LoadHowMuch -> InputT GHCi 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.+  lift discardActiveBreakPoints++  lift 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 :: SuccessFlag+          -> Bool   -- keep the remembered_ctx, as far as possible (:reload)+          -> InputT GHCi ()+afterLoad ok retain_context = do+  lift revertCAFs  -- always revert CAFs on load.+  lift discardTickArrays+  loaded_mods <- getLoadedModules+  modulesLoadedMsg ok loaded_mods+  lift $ setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()+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+        :: Bool                 -- True  <=> keep all of remembered_ctx+                                -- False <=> just keep package imports+        -> [InteractiveImport]  -- new context+        -> GHCi ()++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 :: [InteractiveImport] -> GHCi [InteractiveImport]+keepPackageImports = filterM is_pkg_import+  where+     is_pkg_import :: InteractiveImport -> GHCi 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 :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()+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 -> backend)+         -> IORef ClashOpts+         -> [FilePath]+         -> InputT GHCi ()+makeHDL' backend opts lst = makeHDL backend opts =<< 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+      _                      -> []++makeHDL :: GHC.GhcMonad m+        => Clash.Backend.Backend backend+        => (Int -> HdlSyn -> backend)+        -> IORef ClashOpts+        -> [FilePath]+        -> m ()+makeHDL backend optsRef srcs = do+  dflags <- GHC.getSessionDynFlags+  liftIO $ do startTime <- Clock.getCurrentTime+              opts  <- readIORef optsRef+              let iw = opt_intWidth opts+                  fp = opt_floatSupport opts+                  syn = opt_hdlSyn opts+                  -- 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+                  opts' = opts {opt_hdlDir = maybe outputDir Just (opt_hdlDir opts)+                               ,opt_importPaths = idirs}+                  backend' = backend iw syn+              primDirs <- Clash.Backend.primDirs backend'+              forM_ srcs $ \src -> do+                (bindingsMap,tcm,tupTcm,topEntities,primMap) <-+                  generateBindings primDirs idirs (Clash.Backend.hdlKind backend') src (Just dflags)+                prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+                let prepStartDiff = Clock.diffUTCTime prepTime startTime+                putStrLn $ "Loading dependencies took " ++ show prepStartDiff+                Clash.Driver.generateHDL bindingsMap (Just backend') primMap tcm+                  tupTcm (ghcTypeToHWType iw fp) reduceConstant topEntities opts' (startTime,prepTime)++makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VHDLState)++makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> SystemVerilogState)++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: String -> InputT GHCi ()+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 :: String -> InputT GHCi ()+typeAtCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos      <- mod_infos <$> getGHCiState+    (info, ty) <- findType infos span' sample+    lift $ printForUserModInfo (modinfoInfo info)+                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: String -> InputT GHCi ()+usesCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos  <- mod_infos <$> getGHCiState+    uses   <- findNameUses infos span' sample+    forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: String -> InputT GHCi ()+locAtCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos    <- mod_infos <$> getGHCiState+    (_,_,sp) <- findLoc infos span' sample+    liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: String -> InputT GHCi ()+allTypesCmd _ = runExceptGhcMonad $ do+    infos <- 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)+                              (mkRealSrcLoc fs el ec)++    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+    ec = srcSpanEndCol    spn++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: Bool -> String -> InputT GHCi ()+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 :: String -> InputT GHCi 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 :: String -> InputT GHCi ()+isSafeCmd m =+    case words m of+        [s] | looksLikeModuleName s -> do+            md <- lift $ lookupModule s+            isSafeModule md+        [] -> do md <- guessCurrentModule "issafe"+                 isSafeModule md+        _ -> throwGhcException (CmdLineError "syntax:  :issafe <module>")++isSafeModule :: Module -> InputT GHCi ()+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 :: Bool -> String -> InputT GHCi ()+browseCmd bang m =+  case words m of+    ['*':s] | looksLikeModuleName s -> do+        md <- lift $ wantInterpretedModule s+        browseModule bang md False+    [s] | looksLikeModuleName s -> do+        md <- lift $ lookupModule s+        browseModule bang md True+    [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+             browseModule bang md True+    _ -> throwGhcException (CmdLineError "syntax:  :browse <module>")++guessCurrentModule :: String -> InputT GHCi 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 :: Bool -> Module -> Bool -> InputT GHCi ()+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 :: String -> GHCi ()+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 :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+   addModulesToContext_ starred unstarred++addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext_ starred unstarred = do+   mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+   setGHCContextFromGHCiState++remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()+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 :: ModuleName -> GHCi ()+   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 :: [ModuleName] -> [ModuleName] -> GHCi ()+setContext starred unstarred = restoreContextOnFailure $ do+  modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+                                -- delete the transient context+  addModulesToContext_ starred unstarred++addImportToContext :: String -> GHCi ()+addImportToContext str = restoreContextOnFailure $ do+  idecl <- GHC.parseImportDecl str+  addII (IIDecl idecl)   -- #5836+  setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: InteractiveImport -> GHCi ()+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 :: GHCi a -> GHCi 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 :: InteractiveImport -> GHCi ()+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 :: GHCi ()+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 :: [InteractiveImport] -> GHCi [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 (ideclQualified d1) || 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 :: String -> GHCi ()+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+    _ -> case toArgs str of+         Left err -> liftIO (hPutStrLn stderr err)+         Right wds -> setOptions wds++setiCmd :: String -> GHCi ()+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 :: Bool -> GHCi ()+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) (llvmTargets 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 :: [String] -> GHCi ()+setProg, setEditor, setStop :: String -> GHCi ()++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 })++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+       if all ((/= nm) . fst) old_breaks+              then printForUser (text "Breakpoint" <+> ppr nm <+>+                                 text "does not exist")+              else do+       let new_breaks = map fn old_breaks+           fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })+                      | otherwise = (i,loc)+       setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: PromptFunction -> GHCi ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: PromptFunction -> GHCi ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+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 :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()+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 :: (PromptFunction -> GHCi ()) ->  String -> GHCi ()+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 :: Bool -> [String] -> GHCi ()+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"+      GHC.setInteractiveDynFlags idflags1+      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..."+          GHC.setTargets []+          _ <- GHC.load LoadAllTargets+          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 :: String -> GHCi ()+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 :: String -> GHCi ()++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 :: String -> GHCi ()+showCmd ""   = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+    st <- getGHCiState+    dflags <- getDynFlags++    let lookupCmd :: String -> Maybe (GHCi ())+        lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++        -- (show in help?, command name, action)+        action :: String -> GHCi () -> (Bool, String, GHCi ())+        action name m = (True, name, m)++        hidden :: String -> GHCi () -> (Bool, String, GHCi ())+        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+            , 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 :: String -> GHCi ()+showiCmd str = do+  case words str of+        ["languages"]  -> showiLanguages -- backwards compat+        ["language"]   -> showiLanguages+        ["lang"]       -> showiLanguages -- useful abbreviation+        _ -> throwGhcException (CmdLineError ("syntax:  :showi language"))++showImports :: GHCi ()+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 :: GHCi ()+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 :: GHCi ()+showBindings = do+    bindings <- GHC.getBindings+    (insts, finsts) <- GHC.getInsts+    docs     <- mapM makeDoc (reverse bindings)+                  -- reverse so the new ones come last+    let idocs  = map GHC.pprInstanceHdr insts+        fidocs = map GHC.pprFamInst finsts+    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 :: TyThing -> GHCi ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++showBkptTable :: GHCi ()+showBkptTable = do+  st <- getGHCiState+  printForUser $ prettyLocations (breaks st)++showContext :: GHCi ()+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 :: GHCi ()+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 :: GHCi ()+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 :: GHCi ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHCi ()+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) (llvmTargets dflags) `lang_set`+         case language dflags of+           Nothing -> Just Haskell2010+           other   -> other++showTargets :: GHCi ()+showTargets = mapM_ showTarget =<< GHC.getTargets+  where+    showTarget :: Target -> GHCi ()+    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+    :: CompletionFunc GHCi++-- | 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 `isPrefixOf`) 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 :: String -> GHCi [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 :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi+wrapCompleter breakChars fun = completeWord Nothing breakChars+    $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi+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 :: String -> GHCi ()+sprintCmd = pprintCommand False False+printCmd  = pprintCommand True False+forceCmd  = pprintCommand False True++pprintCommand :: Bool -> Bool -> String -> GHCi ()+pprintCommand bind force str = do+  pprintClosureCommand bind force str++stepCmd :: String -> GHCi ()+stepCmd arg = withSandboxOnly ":step" $ step arg+  where+  step []         = doContinue (const True) GHC.SingleStep+  step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: String -> GHCi ()+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 loc -> do+           Just md <- getCurrentBreakModule+           current_toplevel_decl <- enclosingTickSpan md loc+           doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: String -> GHCi ()+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 :: Module -> SrcSpan -> GHCi 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 :: String -> GHCi ()+traceCmd arg+  = withSandboxOnly ":trace" $ tr arg+  where+  tr []         = doContinue (const True) GHC.RunAndLogSteps+  tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: String -> GHCi ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++-- doContinue :: SingleStep -> GHCi ()+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()+doContinue pre step = do+  runResult <- resume pre step+  _ <- afterRunStmt pre runResult+  return ()++abandonCmd :: String -> GHCi ()+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 :: String -> GHCi ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+   deleteSwitch $ words argLine+   where+   deleteSwitch :: [String] -> GHCi ()+   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 :: String -> GHCi ()+      deleteOneBreak str+         | all isDigit str = deleteBreak (read str)+         | otherwise = return ()++historyCmd :: String -> GHCi ()+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 :: String -> GHCi ()+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 :: String -> GHCi ()+forwardCmd arg+  | null arg        = forward 1+  | all isDigit arg = forward (read arg)+  | otherwise       = liftIO $ putStrLn "Syntax:  :back [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 :: String -> GHCi ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: [String] -> GHCi ()+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 :: Module -> [String] -> GHCi ()+breakByModule md (arg1:rest)+   | all isDigit arg1 = do  -- looks like a line number+        breakByModuleLine md (read arg1) rest+breakByModule _ _+   = breakSyntax++breakByModuleLine :: Module -> Int -> [String] -> GHCi ()+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 :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()+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 = ""+                       }+         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 :: String -> GHCi ()+whereCmd = noArgs $ do+  mstrs <- getCallStackAtCurrentBreakpoint+  case mstrs of+    Nothing -> return ()+    Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: String -> InputT GHCi ()+listCmd c = listCmd' c++listCmd' :: String -> InputT GHCi ()+listCmd' "" = do+   mb_span <- lift 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 :: [String] -> InputT GHCi ()+list2 [arg] | all isDigit arg = do+    imports <- GHC.getContext+    case iiModules imports of+        [] -> liftIO $ putStrLn "No module to list"+        (mn : _) -> do+          md <- lift $ 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 )+                               lift $ 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 :: Module -> Int -> InputT GHCi ()+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 -> InputT 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 :: Module -> GHCi 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 :: GHCi ()+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 :: GHCi ()+discardActiveBreakPoints = do+   st <- getGHCiState+   mapM_ (turnOffBreak.snd) (breaks st)+   setGHCiState $ st { breaks = [] }++deleteBreak :: Int -> GHCi ()+deleteBreak identity = do+   st <- getGHCiState+   let oldLocations    = breaks st+       (this,rest)     = partition (\loc -> fst loc == identity) oldLocations+   if null this+      then printForUser (text "Breakpoint" <+> ppr identity <+>+                         text "does not exist")+      else do+           mapM_ (turnOffBreak.snd) this+           setGHCiState $ st { breaks = rest }++turnOffBreak :: BreakLocation -> GHCi ()+turnOffBreak loc = do+  (arr, _) <- getModBreak (breakModule loc)+  hsc_env <- GHC.getSession+  liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False++getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)+getModBreak m = do+   Just mod_info <- 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 :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()+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 :: SomeException -> GHCi Bool++handler exception = do+  flushInterpBuffers+  withSignalHandlers $+     ghciHandle handler (showException exception >> return False)++showException :: SomeException -> GHCi ()+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 :: GHCi a -> GHCi (Either SomeException a)+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)++tryBool :: GHCi a -> GHCi 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 -> InputT 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
+ src-bin-841/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | 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+    }++-- | 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.+    }++-- | 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 = ml_obj_file (ms_location (modinfoSummary mi))+                last' = modinfoLastUpdate mi+            exists <- doesFileExist fp+            if exists+                then (> last') <$> getModificationTime fp+                else return True++-- | 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+    now <- liftIO getCurrentTime+    return (ModInfo m allTypes i now)++-- | 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 (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _})+        = 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 (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 (L spn pat) =+        pure (Just (getMaybeId pat,spn,hsPatType pat))+      where+        getMaybeId (VarPat (L _ vid)) = Just vid+        getMaybeId _                  = Nothing++    -- | Get ALL source spans in the source.+    listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]+    listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+      where+        p (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-841/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI.Monad (+        GHCi(..), startGHCi,+        GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,+        GHCiOption(..), isOptionSet, setOption, unsetOption,+        Command(..),+        PromptFunction,+        BreakLocation(..),+        TickArray,+        getDynFlags,++        runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,++        printForUserNeverQualify, printForUserModInfo,+        printForUser, printForUserPartWay, prettyLocations,+        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 DynFlags+import FastString+import HscTypes+import SrcLoc+import Module+import GHCi+import GHCi.RemoteTypes+import HsSyn (ImportDecl, GhcPs)+import Util++import Exception+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 qualified System.Console.Haskeline as Haskeline+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+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,+        options        :: [GHCiOption],+        line_number    :: !Int,         -- ^ input line+        break_ctr      :: !Int,+        breaks         :: ![(Int, 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+        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+   }++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++data BreakLocation+   = BreakLocation+   { breakModule :: !GHC.Module+   , breakLoc    :: !SrcSpan+   , breakTick   :: {-# UNPACK #-} !Int+   , onBreakCmd  :: String+   }++instance Eq BreakLocation where+  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+                 breakTick loc1   == breakTick loc2++prettyLocations :: [(Int, BreakLocation)] -> SDoc+prettyLocations []   = text "No active breakpoints."+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs++instance Outputable BreakLocation where+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>+                if null (onBreakCmd loc)+                   then Outputable.empty+                   else doubleQuotes (text (onBreakCmd loc))++recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)+recordBreak brkLoc = do+   st <- getGHCiState+   let oldActiveBreaks = breaks st+   -- 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 = (oldCounter, brkLoc) : oldActiveBreaks+                        }+      return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a+reifyGHCi f = GHCi f'+  where+    -- f' :: IORef GHCiState -> Ghc a+    f' gs = reifyGhc (f'' gs)+    -- f'' :: IORef GHCiState -> Session -> IO a+    f'' gs s = f (s, gs)++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Functor GHCi where+    fmap = liftM++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 HasGhciState m where+    getGHCiState    :: m GHCiState+    setGHCiState    :: GHCiState -> m ()+    modifyGHCiState :: (GHCiState -> GHCiState) -> m ()++instance HasGhciState GHCi where+    getGHCiState      = GHCi $ \r -> liftIO $ readIORef r+    setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s+    modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f++instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where+    getGHCiState    = lift getGHCiState+    setGHCiState    = lift . setGHCiState+    modifyGHCiState = lift . modifyGHCiState++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 Haskeline.MonadException Ghc where+  controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+                    run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)+                    in fmap (flip unGhc s) $ f run'++instance Haskeline.MonadException GHCi where+  controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+                    run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)+                    in fmap (flip unGHCi s) $ f run'++instance ExceptionMonad (InputT GHCi) where+  gcatch = Haskeline.catch+  gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)++isOptionSet :: GHCiOption -> GHCi Bool+isOptionSet opt+ = do st <- getGHCiState+      return (opt `elem` options st)++setOption :: GHCiOption -> GHCi ()+setOption opt+ = do st <- getGHCiState+      setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GHCiOption -> GHCi ()+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 :: SDoc -> GHCi ()+printForUserPartWay doc = do+  unqual <- GHC.getPrintUnqual+  dflags <- getDynFlags+  liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc++-- | Run a single Haskell expression+runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt expr 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 expr opts++runDecls :: String -> GHCi (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)++resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi 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++timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a+timeIt getAllocs action+  = do b <- lift $ isOptionSet ShowTiming+       if not b+          then action+          else do time1   <- liftIO $ getCurrentTime+                  a <- action+                  let allocs = getAllocs a+                  time2   <- liftIO $ getCurrentTime+                  dflags  <- getDynFlags+                  let period = time2 `diffUTCTime` time1+                  liftIO $ printTimes dflags allocs (realToFrac period)+                  return a++printTimes :: DynFlags -> Maybe Integer -> Double -> IO ()+printTimes dflags mallocs 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 :: GHCi ()+revertCAFs = do+  liftIO rts_revertCAFs+  s <- getGHCiState+  when (not (ghc_e s)) turnOffBuffering+     -- Have to turn off buffering again, because we just+     -- reverted stdout, stderr & stdin to their defaults.++foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()+        -- Make it "safe", just in case++-----------------------------------------------------------------------------+-- 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+  nobuf <- compileGHCiExpr $+   "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " +++       " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " +++       " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"+  flush <- compileGHCiExpr $+   "do { System.IO.hFlush System.IO.stdout; " +++       " System.IO.hFlush System.IO.stderr }"+  return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GHCi ()+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 :: GHCi ()+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 =+  compileGHCiExpr $+    "\\m -> System.Environment.withProgName " ++ show progname +++    "(System.Environment.withArgs " ++ show args ++ " m)"++compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue+compileGHCiExpr expr = do+  hsc_env <- getSession+  let dflags = hsc_dflags hsc_env+      -- RebindableSyntax can wreak havoc with GHCi in several ways+      -- (see #13385 and #14342 for examples), so we take care to disable it+      -- for the duration of running expressions that are internal to GHCi.+      no_rb_hsc_env =+        hsc_env { hsc_dflags = xopt_unset dflags LangExt.RebindableSyntax }+  setSession no_rb_hsc_env+  res <- GHC.compileExprRemote expr+  setSession hsc_env+  pure res
+ src-bin-841/Clash/GHCi/UI/Tags.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+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 Data.Function+import Data.Maybe+import Data.Ord+import DriverPhases+import Panic+import Data.List+import Control.Monad+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-841/Clash/Main.hs view
@@ -0,0 +1,1102 @@+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Clash.Main (defaultMain) where++-- For Int/Word size+#include "MachDeps.h"++-- 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(GHCI)+import Clash.GHCi.UI          ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++-- Frontend plugins+#if defined(GHCI)+import DynamicLoading   ( loadFrontendPlugin )+import Plugins+#else+import DynamicLoading   ( pluginError )+#endif+import Module           ( ModuleName )+++-- Various other random stuff that we need+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 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 Data.Char+import Data.List+import Data.Maybe++-- clash additions+import           Paths_clash_ghc+import           Clash.GHCi.UI (makeHDL)+import           Exception (gcatch)+import           Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Version (showVersion)+import           Control.Exception (Exception(..),ErrorCall (..))++import qualified GHC.LanguageExtensions as LangExt+import           GHC.Exception ( SomeException )++import qualified Clash.Backend+import           Clash.Backend.SystemVerilog (SystemVerilogState)+import           Clash.Backend.VHDL    (VHDLState)+import           Clash.Backend.Verilog (VerilogState)+import           Clash.Driver.Types+  (ClashOpts (..), ClashException (..), DebugLevel (..))+import           Clash.GHC.ClashFlags+import           Clash.Netlist.BlackBox.Types (HdlSyn (..))+import           Clash.Util (clashLibVersion)+import           Clash.GHC.LoadModules (ghcLibDir)++-----------------------------------------------------------------------------+-- 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++   -- Handle GHC-specific character encoding flags, allowing us to control how+   -- GHC produces output regardless of OS.+   env <- getEnvironment+   case lookup "GHC_CHARENC" env of+    Just "UTF-8" -> do+     hSetEncoding stdout utf8+     hSetEncoding stderr utf8+    _ -> do+     -- Avoid GHC erroring out when trying to display unhandled characters+     hSetTranslit stdout+     hSetTranslit stderr++   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 argv2 = map (mkGeneralLocated "on the commandline") argv1+    libDir <- ghcLibDir++    let argv1 = map (mkGeneralLocated "on the commandline") argv0+    r <- newIORef (ClashOpts { opt_dbgLevel    = DebugNone+                             , opt_inlineLimit = 20+                             , opt_specLimit   = 20+                             , opt_inlineFunctionLimit = 15+                             , opt_inlineConstantLimit = 0+                             , opt_cachehdl    = True+                             , opt_cleanhdl    = True+                             , opt_intWidth    = WORD_SIZE_IN_BITS+                             , opt_hdlDir      = Nothing+                             , opt_hdlSyn      = Other+                             , opt_errorExtra  = False+                             , opt_floatSupport = False+                             , opt_allowZero   = False+                             , opt_importPaths = []+                             })+    (argv2, clashFlagWarnings) <- parseClashFlags r argv1++    -- 2. Parse the "mode" flags (--make, --interactive etc.)+    -- (mode, argv3, flagWarnings) <- parseModeFlags argv2+    (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+                   ShowVersion               -> showVersion+                   ShowNumVersion            -> putStrLn cProjectVersion+                   ShowOptions isInteractive -> showOptions isInteractive+        Right postStartupMode ->+            -- start our GHC session+            GHC.runGhc (Just libDir) $ do++            dflags <- GHC.getSessionDynFlags+            let dflagsExtra = foldl DynFlags.xopt_set+                                    dflags+                                    [ LangExt.TemplateHaskell+                                    , LangExt.TemplateHaskellQuotes+                                    , LangExt.DataKinds+                                    , LangExt.MonoLocalBinds+                                    , LangExt.TypeOperators+                                    , LangExt.FlexibleContexts+                                    , LangExt.ConstraintKinds+                                    , LangExt.TypeFamilies+                                    , LangExt.BinaryLiterals+                                    , LangExt.ExplicitNamespaces+                                    , LangExt.KindSignatures+                                    , LangExt.DeriveLift+                                    , LangExt.TypeApplications+                                    , LangExt.ScopedTypeVariables+                                    , LangExt.MagicHash+                                    , LangExt.ExplicitForAll+                                    ]+                dflagsExtra1 = foldl DynFlags.xopt_unset dflagsExtra+                                     [ LangExt.ImplicitPrelude+                                     , LangExt.MonomorphismRestriction+                                     ]++                ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+                ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+                ghcTyLitKNPlugin   = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+                dflagsExtra2 = dflagsExtra1+                                  { DynFlags.pluginModNames = nub $+                                      ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+                                      ghcTyLitKNPlugin :+                                      DynFlags.pluginModNames dflagsExtra1+                                  }++            case postStartupMode of+                Left preLoadMode ->+                    liftIO $ do+                        case preLoadMode of+                            ShowInfo               -> showInfo dflagsExtra2+                            ShowGhcUsage           -> showGhcUsage  dflagsExtra2+                            ShowGhciUsage          -> showGhciUsage dflagsExtra2+                            PrintWithDynFlags f    -> putStrLn (f dflagsExtra2)+                Right postLoadMode ->+                    main' postLoadMode dflagsExtra2 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, dflt_target,    LinkInMemory)+               DoVerilog       -> (CompManager, dflt_target,    LinkInMemory)+               DoSystemVerilog -> (CompManager, dflt_target,    LinkInMemory)+               _               -> (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 - e.g., for win32 platforms, backslashes are converted+     -- into forward slashes.+    normal_fileish_paths = map (normalise . 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 srcs Nothing+       DoEval exprs           -> ghciUI clashOpts srcs $ Just $ reverse exprs+       DoAbiHash              -> abiHash (map fst srcs)+       ShowPackages           -> liftIO $ showPackages dflags6+       DoFrontend f           -> doFrontend f srcs+       DoVHDL                 -> clash makeVHDL+       DoVerilog              -> clash makeVerilog+       DoSystemVerilog        -> clash makeSystemVerilog+       DoBackpack             -> doBackpack (map fst srcs)++  liftIO $ dumpFinalStats dflags6++handleClashException+  :: GhcMonad m+  => DynFlags+  -> ClashOpts+  -> SomeException+  -> m a+handleClashException df opts e = case fromException e of+  Just (ClashException sp s eM) ->+    throwOneError (mkPlainErrMsg df sp (text s $$ blankLine $$ srcInfo $$ showExtra (opt_errorExtra opts) eM))+  _ -> case fromException e of+    Just (ErrorCall msg) ->+      throwOneError (mkPlainErrMsg df noSrcSpan (text "Clash error call:" $$ text msg))+    _ -> case fromException e of+      Just (e' :: SourceError) -> do+        GHC.printException e'+        liftIO $ exitWith (ExitFailure 1)+      _ -> throwOneError (mkPlainErrMsg df noSrcSpan (text "Other error:" $$ text (displayException e)))+  where+    srcInfo = text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$+              text "The actual location of the error can be in a function that is inlined." $$+              text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."++    showExtra False (Just _)   =+      blankLine $$+      text "This error contains additional information, rerun with '-fclash-error-extra' to show this information."+    showExtra True  (Just msg) =+      blankLine $$+      text "Additional information:" $$ blankLine $$+      text msg+    showExtra _ _ = empty++ghciUI :: IORef ClashOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()+#if !defined(GHCI)+ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI opts  = interactiveUI (defaultGhciSettings opts)+#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"+      _ -> 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(GHCI)+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 DoVHDL              = True+isLinkMode DoVerilog           = True+isLinkMode DoSystemVerilog     = 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(GHCI)+   -- 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++showSupportedExtensions :: IO ()+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions++showVersion :: IO ()+showVersion = putStrLn $ concat [ "CLaSH, version "+                                , Data.Version.showVersion Paths_clash_ghc.version+                                , " (using clash-lib, version: "+                                , Data.Version.showVersion clashLibVersion+                                , ")"+                                ]++showOptions :: Bool -> IO ()+showOptions isInteractive = putStr (unlines availableOptions)+    where+      availableOptions = concat [+        flagsForCompletion isInteractive,+        map ('-':) (getFlagNames mode_flags)+        ]+      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+  buckets <- getFastStringTable+  let (entries, longest, has_z) = countFS 0 0 0 buckets+      msg = text "FastString stats:" $$+            nest 4 (vcat [text "size:           " <+> int (length buckets),+                          text "entries:        " <+> int entries,+                          text "longest chain:  " <+> int longest,+                          text "has z-encoding: " <+> (has_z `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 '%'++countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)+countFS entries longest has_z [] = (entries, longest, has_z)+countFS entries longest has_z (b:bs) =+  let+        len = length b+        longest' = max len longest+        entries' = entries + len+        has_zs = length (filter hasZEncoding b)+  in+        countFS entries' longest' (has_z + has_zs) bs++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 ()+#if !defined(GHCI)+doFrontend modname _ = pluginError [modname]+#else+doFrontend modname srcs = do+    hsc_env <- getSession+    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname+    frontend frontend_plugin+      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs+#endif++-- -----------------------------------------------------------------------------+-- 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 (Trac #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) ifaces+  f <- fingerprintBinMem bh++  putStrLn (showPpr dflags f)++-----------------------------------------------------------------------------+-- VHDL Generation++makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> 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 :: Int -> HdlSyn -> VHDLState)++makeVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VerilogState)++makeSystemVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> 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.+-}++foreign import ccall safe "initGCStatistics"+  initGCStatistics :: IO ()
− src-bin/CLaSH/GHCi/HsVersions.h 
@@ -1,52 +0,0 @@-#ifndef HSVERSIONS_H-#define HSVERSIONS_H--#if 0--IMPORTANT!  If you put extra tabs/spaces in these macro definitions,-you will screw up the layout where they are used in case expressions!--(This is cpp-dependent, of course)--#endif--/* Useful in the headers that we share with the RTS */-#define COMPILING_GHC 1--/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */-/* #include "ghc_boot_platform.h" */--/* Pull in the autoconf defines (HAVE_FOO), but don't include- * ghcconfig.h, because that will include ghcplatform.h which has the- * wrong platform settings for the compiler (it has the platform- * settings for the target plat instead). */-/* #include "ghcautoconf.h" */--#define GLOBAL_VAR(name,value,ty)  \-{-# NOINLINE name #-};             \-name :: IORef (ty);                \-name = Util.global (value);--#define GLOBAL_VAR_M(name,value,ty) \-{-# NOINLINE name #-};              \-name :: IORef (ty);                 \-name = Util.globalM (value);--#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else-#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $---- Examples:   Assuming   flagSet :: String -> m Bool------    do { c   <- getChar; MASSERT( isUpper c ); ... }---    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }---    do { str <- getStr;  ASSERTM( flagSet str ); .. }---    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }---    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }-#define MASSERT(e)      ASSERT(e) return ()-#define MASSERT2(e,msg) ASSERT2(e,msg) return ()-#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }-#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }-#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }--#endif /* HsVersions.h */
− src-bin/CLaSH/GHCi/UI.hs 
@@ -1,3652 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS -fno-cse #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- 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, runDecls )-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-import GhcMonad ( modifySession )-import qualified GHC-import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),-             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,-             getModuleGraph, handleSourceError )-import HsImpExp-import HsSyn-import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,-                  setInteractivePrintName, hsc_dflags, msObjFilePath )-import Module-import Name-import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag )-import PprTyThing-import PrelNames-import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )-import SrcLoc-import qualified Lexer--import StringBuffer-import Outputable hiding ( printForUser, printForUserPartWay, bold )---- Other random utilities-import BasicTypes hiding ( isTopLevel )-import Config-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---- 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, nub,-                   partition, sort, sortBy )-import Data.Maybe-import qualified Data.Map as M--import Exception hiding (catch)-import Foreign-import GHC.Stack hiding (SrcLoc(..))--import System.Directory-import System.Environment-import System.Exit ( exitWith, ExitCode(..) )-import System.FilePath-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)--#ifndef mingw32_HOST_OS-import System.Posix hiding ( getEnv )-#else-import qualified System.Win32-#endif--import GHC.IO.Exception ( IOErrorType(InvalidArgument) )-import GHC.IO.Handle ( hFlushAll )-import GHC.TopHandler ( topHandler )--import qualified 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.Netlist.BlackBox.Types (HdlSyn)-import           CLaSH.Util (clashLibVersion)-import           Control.DeepSeq-import qualified Data.Time.Clock as Clock-import qualified Data.Version as Data.Version-import qualified Paths_clash_ghc---------------------------------------------------------------------------------data GhciSettings = GhciSettings {-        availableCommands :: [Command],-        shortHelpText     :: String,-        fullHelpText      :: String,-        defPrompt         :: String,-        defPrompt2        :: String-    }--defaultGhciSettings :: IORef CLaSHOpts -> GhciSettings-defaultGhciSettings opts =-    GhciSettings {-        availableCommands = ghciCommands opts,-        shortHelpText     = defShortHelpText,-        defPrompt         = default_prompt,-        defPrompt2        = default_prompt2,-        fullHelpText      = defFullHelpText-    }--ghciWelcomeMsg :: String-ghciWelcomeMsg = "CLaSHi, version " ++ Data.Version.showVersion Paths_clash_ghc.version ++-                 " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion ++-                 "):\nhttp://www.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),-  ("edit",      keepGoing' editFile,            completeFilename),-  ("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_ False), completeHomeModuleOrFile),-  ("load!",     keepGoingPaths (loadModule_ True), completeHomeModuleOrFile),-  ("list",      keepGoing' listCmd,             noCompletion),-  ("module",    keepGoing moduleCmd,            completeSetModule),-  ("main",      keepGoing runMain,              completeFilename),-  ("print",     keepGoing printCmd,             completeExpression),-  ("quit",      quit,                           noCompletion),-  ("reload",    keepGoing' (reloadModule False), noCompletion),-  ("reload!",   keepGoing' (reloadModule True), 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),-  ("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)-  ] ++ 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" ++-  "   :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" ++-  "   :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" ++-  "   :undef <cmd>                undefine user-defined command :<cmd>\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 breakpoint\n" ++-  "   :delete *                   delete 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 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 prompt2 <prompt>       set the continuation prompt used in GHCi\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 <setting>             show value of <setting>, which is one of\n" ++-  "                                  [args, prog, prompt, editor, stop]\n" ++-  "   :showi language             show language flags for interactive evaluation\n" ++-  "\n"--findEditor :: IO String-findEditor = do-  getEnv "EDITOR"-    `catchIO` \_ -> do-#if mingw32_HOST_OS-        win <- System.Win32.getWindowsDirectory-        return (win </> "notepad.exe")-#else-        return ""-#endif--default_progname, default_prompt, default_prompt2, default_stop :: String-default_progname = "<interactive>"-default_prompt = "%s> "-default_prompt2 = "%s| "-default_stop = ""--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.-   dflags <- getDynFlags-   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)-               . (`xopt_unset` LangExt.MonomorphismRestriction)-               $ dflags-   GHC.setInteractiveDynFlags dflags'--   lastErrLocationsRef <- liftIO $ newIORef []-   progDynFlags <- GHC.getProgramDynFlags-   _ <- GHC.setProgramDynFlags $-      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }--   when (isNothing maybe_exprs) $ do-        -- Only for GHCi (not runghc and ghc -e):--        -- Turn buffering off for the compiled program's stdout/stderr-        turnOffBuffering_ nobuffering-        -- Turn buffering off for GHCi's stdout-        liftIO $ hFlush stdout-        liftIO $ hSetBuffering stdout NoBuffering-        -- We don't want the cmd line to buffer any input that might be-        -- intended for the program, so unbuffer stdin.-        liftIO $ hSetBuffering stdin NoBuffering-        liftIO $ hSetBuffering stderr NoBuffering-#if defined(mingw32_HOST_OS)-        -- On Unix, stdin will use the locale encoding.  The IO library-        -- doesn't do this on Windows (yet), so for now we use UTF-8,-        -- for consistency with GHC 6.10 and to make the tests work.-        liftIO $ hSetEncoding stdin utf8-#endif--   default_editor <- liftIO $ findEditor-   eval_wrapper <- mkEvalWrapper default_progname default_args-   startGHCi (runGHCi srcs maybe_exprs)-        GHCiState{ progname           = default_progname,-                   args               = default_args,-                   evalWrapper        = eval_wrapper,-                   prompt             = defPrompt config,-                   prompt2            = defPrompt2 config,-                   stop               = default_stop,-                   editor             = default_editor,-                   options            = [],-                   -- 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             = [],-                   tickarrays         = emptyModuleEnv,-                   ghci_commands      = availableCommands config,-                   ghci_macros        = [],-                   last_command       = Nothing,-                   cmdqueue           = [],-                   remembered_ctx     = [],-                   transient_ctx      = [],-                   ghc_e              = isJust maybe_exprs,-                   short_help         = shortHelpText config,-                   long_help          = fullHelpText config,-                   lastErrorLocations = lastErrLocationsRef,-                   mod_infos          = M.empty,-                   flushStdHandles    = flush,-                   noBuffering        = nobuffering-                 }--   return ()--resetLastErrorLocations :: GHCi ()-resetLastErrorLocations = do-    st <- getGHCiState-    liftIO $ writeIORef (lastErrorLocations st) []--ghciLogAction :: IORef [(FastString, Int)] ->  LogAction-ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do-    defaultLogAction 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--   current_dir = return (Just ".clashi")--   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--  dot_cfgs <- if ignore_dot_ghci then return [] else do-    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]-    liftIO $ filterM checkFileAndDirPerms dot_files-  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs--  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 $ (catMaybes mdot_cfgs) ++ arg_cfgs-    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.--  -- 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-            -- enter the interactive loop-            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty-        Just exprs -> do-            -- just evaluate the expression we were given-            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 Trac #7962-                _ <- runCommands' hdle-                     (Just $ hdle (toException $ ExitFailure 1) >> return ())-                     (return Nothing)-                return ()--  -- and finally, exit-  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving CLaSHi."--runGHCiInput :: InputT GHCi a -> GHCi a-runGHCiInput f = do-    dflags <- getDynFlags-    histFile <- if gopt Opt_GhciHistory dflags-                then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "clashi_history")))-                                             (return Nothing)-                else return Nothing-    runInputT-        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})-        f---- | How to get the next input line from the user-nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)-nextInputLine show_prompt is_tty-  | is_tty = do-    prmpt <- if show_prompt then lift mkPrompt else return ""-    r <- getInputLine prmpt-    incrementLineNo-    return r-  | otherwise = do-    when show_prompt $ lift mkPrompt >>= liftIO . putStr-    fileLoop stdin---- NOTE: We only read .ghci files if they are owned by the current user,--- and aren't world writable (files owned by root are ok, see #9324).--- Otherwise, we could be accidentally running code planted by--- a malicious third party.---- Furthermore, We only read ./.ghci if . is owned by the current user--- and isn't writable by anyone else.  I think this is sufficient: we--- don't need to check .. and ../.. etc. because "."  always refers to--- the same directory while a process is running.--checkFileAndDirPerms :: FilePath -> IO Bool-checkFileAndDirPerms file = do-  file_ok <- checkPerms file-  -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will-  -- print some confusing and useless warnings in some cases (e.g. in-  -- travis). Note that we can't add a test for this, as all ghci tests should-  -- run with -ignore-dot-ghci, which means we never get here.-  if file_ok then checkPerms (getDirectory file) else return False-  where-  getDirectory f = case takeDirectory f of-    "" -> "."-    d -> d--checkPerms :: FilePath -> IO Bool-#ifdef 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 :: InputT GHCi ()-incrementLineNo = modifyGHCiState incLineNo-  where-    incLineNo st = st { line_number = line_number st + 1 }--fileLoop :: Handle -> InputT GHCi (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')--mkPrompt :: GHCi String-mkPrompt = 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-        modules_bit =-             hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>-             hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])--         --  use the 'as' name if there is one-        myIdeclName d | Just m <- ideclAs d = m-                      | otherwise           = unLoc (ideclName d)--        deflt_prompt = dots <> context_bit <> modules_bit--        f ('%':'l':xs) = ppr (1 + line_number st) <> f xs-        f ('%':'s':xs) = deflt_prompt <> f xs-        f ('%':'%':xs) = char '%' <> f xs-        f (x:xs) = char x <> f xs-        f [] = empty--  dflags <- getDynFlags-  return (showSDoc dflags (f (prompt st)))---queryQueue :: GHCi (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 :: Maybe String -> Bool -> GHCi ()-installInteractivePrint Nothing _  = return ()-installInteractivePrint (Just ipFun) exprmode = do-  ok <- trySuccess $ do-                (name:_) <- GHC.parseName ipFun-                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name-                                      in he{hsc_IC = new_ic})-                return Succeeded--  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))---- | The main read-eval-print loop-runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()-runCommands gCmd = runCommands' handler Nothing gCmd >> return ()--runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler-             -> Maybe (GHCi ()) -- ^ Source error handler-             -> InputT GHCi (Maybe String)-             -> InputT GHCi (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 commmand 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  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $-             handleSourceError printErrorAndFail-               (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 = prompt2 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 (Maybe Bool)--    -- command-    doCommand stmt | (':' : cmd) <- removeSpaces stmt = do-      result <- specialCommand cmd-      case result of-        True -> return Nothing-        _    -> return $ Just True--    -- 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 $ Just True-            Just ml_stmt -> do-              -- temporarily compensate line-number for multi-line input-              result <- timeIt runAllocs $ lift $-                runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion-              return $ Just (runSuccess result)-        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-          result <- timeIt runAllocs $ lift $-            runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion-          return $ Just (runSuccess result)--    -- 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 :: String -> InputT GHCi (Maybe String)-                    -> InputT GHCi (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 = prompt2 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 :: [String] -> GHCi ()-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 :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)-runStmt stmt step = do-  dflags <- GHC.getInteractiveDynFlags-  if | GHC.isStmt dflags stmt    -> run_stmt-     | GHC.isImport dflags stmt  -> 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 stmt -> throwGhcException-       (CmdLineError "error: expecting a single import declaration")-     -- Note: `GHC.isDecl` returns False on input like-     -- `data Infix a b = a :@: b; infixl 4 :@:`-     -- and should therefore not be used here.-     | otherwise                 -> run_decl--  where-    run_import = do-      addImportToContext stmt-      return (Just (GHC.ExecComplete (Right []) 0))--    run_decl =-        do _ <- liftIO $ tryIO $ hFlushAll stdin-           m_result <- GhciMonad.runDecls stmt-           case m_result of-               Nothing     -> return Nothing-               Just result ->-                 Just <$> afterRunStmt (const True)-                            (GHC.ExecComplete (Right result) 0)--    run_stmt =-        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.runStmt stmt step-           case m_result of-               Nothing     -> return Nothing-               Just result -> Just <$> afterRunStmt (const True) result---- | Clean up the GHCi environment after a statement has run-afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi 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-  liftIO installSignalHandlers-  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 ::-  Maybe GHC.BreakInfo -> GHCi (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) <- breaks st,-                                  breakModule loc == md,-                                  breakTick loc == nm ]--printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()-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 :: [Name] -> GHCi ()-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 :: Name -> GHCi ()-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 <- lift $ 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 :: String -> GHCi Bool-shellEscape str = liftIO (system str >> return False)--lookupCommand :: String -> GHCi (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' :: String -> GHCi (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 `isPrefixOf`) . 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--getCurrentBreakSpan :: GHCi (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 :: GHCi (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 :: GHCi (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 :: GHCi () -> String -> GHCi ()-noArgs m "" = m-noArgs _ _  = liftIO $ putStrLn "This command takes no arguments"--withSandboxOnly :: String -> GHCi () -> GHCi ()-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 :: String -> GHCi ()-help _ = do-    txt <- long_help `fmap` getGHCiState-    liftIO $ putStr txt---------------------------------------------------------------------------------- :info--info :: Bool -> String -> InputT GHCi ()-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) -> 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-pprInfo (thing, fixity, cls_insts, fam_insts)-  =  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 :: String -> GHCi ()-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 :: String -> GHCi ()-runRun s = case toCmdArgs s of-           Left err          -> liftIO (hPutStrLn stderr err)-           Right (cmd, args) -> doWithArgs args cmd--doWithArgs :: [String] -> String -> GHCi ()-doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++-                                       show args ++ " (" ++ cmd ++ ")"]---------------------------------------------------------------------------------- :cd--changeDirectory :: String -> InputT GHCi ()-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 graph)) $-        liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."-  GHC.setTargets []-  _ <- GHC.load LoadAllTargets-  lift $ setContextAfterLoad False []-  GHC.workingDirectoryChanged-  dir' <- expandPath dir-  liftIO $ setCurrentDirectory dir'--trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag-trySuccess act =-    handleSourceError (\e -> do GHC.printException e-                                return Failed) $ do-      act---------------------------------------------------------------------------------- :edit--editFile :: String -> InputT GHCi ()-editFile str =-  do file <- if null str then lift 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 False ""---- 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 :: GHCi String-chooseEditFile =-  do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x--     graph <- GHC.getModuleGraph-     failed_graph <- filterM hasFailed 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 :: Bool{-overwrite-} -> String -> GHCi ()-defineMacro _ (':':_) =-  liftIO $ putStrLn "macro name cannot start with a colon"-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-  if (not overwrite && macro_name `elem` defined)-        then throwGhcException (CmdLineError-                ("macro '" ++ macro_name ++ "' is already defined"))-        else do--  -- 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` step `mkHsApp` expr-        tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)-        new_expr = L (getLoc expr) $ ExprWithTySig 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 :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool-runMacro fun s = do-  hsc_env <- GHC.getSession-  str <- liftIO $ evalStringToIOString hsc_env fun s-  enqueueCommands (lines str)-  return False----------------------------------------------------------------------------------- :undef--undefineMacro :: String -> GHCi ()-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 :: String -> GHCi ()-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 :: GHCi (LHsExpr RdrName)-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 body tySig---------------------------------------------------------------------------------- :check--checkModule :: String -> InputT GHCi ()-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----------------------------------------------------------------------------------- :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.-deferredLoad :: Bool -> InputT GHCi SuccessFlag -> InputT GHCi ()-deferredLoad defer load = do-  -- Force originalFlags to avoid leaking the associated HscEnv-  !originalFlags <- getDynFlags-  when defer $ Monad.void $-    GHC.setProgramDynFlags $ setGeneralFlag' Opt_DeferTypeErrors originalFlags-  Monad.void $ load-  Monad.void $ GHC.setProgramDynFlags $ originalFlags--loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag-loadModule fs = timeIt (const Nothing) (loadModule' fs)---- | @:load@ command-loadModule_ :: Bool -> [FilePath] -> InputT GHCi ()-loadModule_ defer fs = deferredLoad defer (loadModule (zip fs (repeat Nothing)))--loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi 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.--  -- unload first-  _ <- GHC.abandonAll-  lift discardActiveBreakPoints-  GHC.setTargets []-  _ <- GHC.load LoadAllTargets--  GHC.setTargets targets-  doLoadAndCollectInfo False LoadAllTargets---- | @:add@ command-addModule :: [FilePath] -> InputT GHCi ()-addModule files = do-  lift revertCAFs -- always revert CAFs on load/add.-  files' <- mapM expandPath files-  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'-  -- 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 ()---- | @:reload@ command-reloadModule :: Bool -> String -> InputT GHCi ()-reloadModule defer m = deferredLoad defer $-                       doLoadAndCollectInfo True loadTargets-  where-    loadTargets | null m    = LoadAllTargets-                | otherwise = LoadUpTo (GHC.mkModuleName m)---- | 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 :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag-doLoadAndCollectInfo retain_context howmuch = do-  doCollectInfo <- lift (isOptionSet CollectInfo)--  doLoad retain_context howmuch >>= \case-    Succeeded | doCollectInfo -> do-      loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name-      v <- mod_infos <$> getGHCiState-      !newInfos <- collectInfo v loaded-      modifyGHCiState (\st -> st { mod_infos = newInfos })-      return Succeeded-    flag -> return flag--doLoad :: Bool -> LoadHowMuch -> InputT GHCi 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.-  lift discardActiveBreakPoints--  lift 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 :: SuccessFlag-          -> Bool   -- keep the remembered_ctx, as far as possible (:reload)-          -> InputT GHCi ()-afterLoad ok retain_context = do-  lift revertCAFs  -- always revert CAFs on load.-  lift discardTickArrays-  loaded_mods <- getLoadedModules-  modulesLoadedMsg ok loaded_mods-  lift $ setContextAfterLoad retain_context loaded_mods--setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()-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' = flattenSCCs (GHC.topSortModuleGraph True ms 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-        :: Bool                 -- True  <=> keep all of remembered_ctx-                                -- False <=> just keep package imports-        -> [InteractiveImport]  -- new context-        -> GHCi ()--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 :: [InteractiveImport] -> GHCi [InteractiveImport]-keepPackageImports = filterM is_pkg_import-  where-     is_pkg_import :: InteractiveImport -> GHCi 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 :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()-modulesLoadedMsg ok mods = do-  dflags <- getDynFlags-  unqual <- GHC.getPrintUnqual-  let mod_name mod = do-        is_interpreted <- GHC.isModuleInterpreted mod-        return $ if is_interpreted-                  then ppr (GHC.ms_mod mod)-                  else ppr (GHC.ms_mod mod)-                       <> text " ("-                       <> text (normalise $ msObjFilePath mod)-                       <> text ")" -- fix #9887-  mod_names <- mapM mod_name mods-  let mod_commas-        | null mods = text "none."-        | otherwise = hsep (punctuate comma mod_names) <> text "."-      status = case ok of-                   Failed    -> text "Failed"-                   Succeeded -> text "Ok"--      msg = status <> text ", modules loaded:" <+> mod_commas--  when (verbosity dflags > 0) $-     liftIO $ putStrLn $ showSDocForUser dflags unqual msg----- | 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 -> backend)-         -> IORef CLaSHOpts-         -> [FilePath]-         -> InputT GHCi ()-makeHDL' backend opts lst = makeHDL backend opts =<< 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-      _                      -> []--makeHDL :: GHC.GhcMonad m-        => CLaSH.Backend.Backend backend-        => (Int -> HdlSyn -> backend)-        -> IORef CLaSHOpts-        -> [FilePath]-        -> m ()-makeHDL backend optsRef srcs = do-  dflags <- GHC.getSessionDynFlags-  liftIO $ do startTime <- Clock.getCurrentTime-              opts  <- readIORef optsRef-              let iw = opt_intWidth opts-                  fp = opt_floatSupport opts-                  syn = opt_hdlSyn opts-                  -- 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-                  opts' = opts {opt_hdlDir = maybe outputDir Just (opt_hdlDir opts)-                               ,opt_importPaths = idirs}-                  backend' = backend iw syn-              primDir <- CLaSH.Backend.primDir backend'-              forM_ srcs $ \src -> do-                (bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM,primMap) <--                  generateBindings (opt_errorInvalidCoercions opts') primDir idirs (CLaSH.Backend.hdlKind backend') src (Just dflags)-                prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime-                let prepStartDiff = Clock.diffUTCTime prepTime startTime-                putStrLn $ "Loading dependencies took " ++ show prepStartDiff-                CLaSH.Driver.generateHDL bindingsMap (Just backend') primMap tcm-                  tupTcm (ghcTypeToHWType iw fp) reduceConstant topEnt testInpM expOutM opts' (startTime,prepTime)--makeVHDL :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: Int -> HdlSyn -> VHDLState)--makeVerilog :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (CLaSH.Backend.initBackend :: Int -> HdlSyn -> VerilogState)--makeSystemVerilog :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (CLaSH.Backend.initBackend :: Int -> HdlSyn -> SystemVerilogState)---------------------------------------------------------------------------------- | @:type@ command--typeOfExpr :: String -> InputT GHCi ()-typeOfExpr str = handleSourceError GHC.printException $ do-    ty <- GHC.exprType str-    printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser ty)]---------------------------------------------------------------------------------- | @:type-at@ command--typeAtCmd :: String -> InputT GHCi ()-typeAtCmd str = runExceptGhcMonad $ do-    (span',sample) <- exceptT $ parseSpanArg str-    infos      <- mod_infos <$> getGHCiState-    (info, ty) <- findType infos span' sample-    lift $ printForUserModInfo (modinfoInfo info)-                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])---------------------------------------------------------------------------------- | @:uses@ command--usesCmd :: String -> InputT GHCi ()-usesCmd str = runExceptGhcMonad $ do-    (span',sample) <- exceptT $ parseSpanArg str-    infos  <- mod_infos <$> getGHCiState-    uses   <- findNameUses infos span' sample-    forM_ uses (liftIO . putStrLn . showSrcSpan)---------------------------------------------------------------------------------- | @:loc-at@ command--locAtCmd :: String -> InputT GHCi ()-locAtCmd str = runExceptGhcMonad $ do-    (span',sample) <- exceptT $ parseSpanArg str-    infos    <- mod_infos <$> getGHCiState-    (_,_,sp) <- findLoc infos span' sample-    liftIO . putStrLn . showSrcSpan $ sp---------------------------------------------------------------------------------- | @:all-types@ command--allTypesCmd :: String -> InputT GHCi ()-allTypesCmd _ = runExceptGhcMonad $ do-    infos <- 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)-                              (mkRealSrcLoc fs el ec)--    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-    ec = srcSpanEndCol    spn---------------------------------------------------------------------------------- | @:kind@ command--kindOfType :: Bool -> String -> InputT GHCi ()-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 :: String -> InputT GHCi 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 :: String -> InputT GHCi ()-isSafeCmd m =-    case words m of-        [s] | looksLikeModuleName s -> do-            md <- lift $ lookupModule s-            isSafeModule md-        [] -> do md <- guessCurrentModule "issafe"-                 isSafeModule md-        _ -> throwGhcException (CmdLineError "syntax:  :issafe <module>")--isSafeModule :: Module -> InputT GHCi ()-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 $ null good)-         (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++-                        (intercalate ", " $ map (showPpr dflags) good))-    case msafe && 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) 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) = ([], [])-                          | otherwise = partition part deps-        where part pkg = trusted $ getPackageDetails dflags pkg---------------------------------------------------------------------------------- :browse---- Browsing a module's contents--browseCmd :: Bool -> String -> InputT GHCi ()-browseCmd bang m =-  case words m of-    ['*':s] | looksLikeModuleName s -> do-        md <- lift $ wantInterpretedModule s-        browseModule bang md False-    [s] | looksLikeModuleName s -> do-        md <- lift $ lookupModule s-        browseModule bang md True-    [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")-             browseModule bang md True-    _ -> throwGhcException (CmdLineError "syntax:  :browse <module>")--guessCurrentModule :: String -> InputT GHCi 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 :: Bool -> Module -> Bool -> InputT GHCi ()-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-                   | otherwise = pprTyThingInContext--            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 :: String -> GHCi ()-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 :: [ModuleName] -> [ModuleName] -> GHCi ()-addModulesToContext starred unstarred = restoreContextOnFailure $ do-   addModulesToContext_ starred unstarred--addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()-addModulesToContext_ starred unstarred = do-   mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)-   setGHCContextFromGHCiState--remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()-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 :: ModuleName -> GHCi ()-   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 :: [ModuleName] -> [ModuleName] -> GHCi ()-setContext starred unstarred = restoreContextOnFailure $ do-  modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }-                                -- delete the transient context-  addModulesToContext_ starred unstarred--addImportToContext :: String -> GHCi ()-addImportToContext str = restoreContextOnFailure $ do-  idecl <- GHC.parseImportDecl str-  addII (IIDecl idecl)   -- #5836-  setGHCContextFromGHCiState---- Util used by addImportToContext and addModulesToContext-addII :: InteractiveImport -> GHCi ()-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 :: GHCi a -> GHCi 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 :: InteractiveImport -> GHCi ()-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 :: GHCi ()-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)-  GHC.setContext $-     if not (any isPreludeImport iidecls)-        then iidecls ++ [implicitPreludeImport]-        else iidecls-    -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up.----- -------------------------------------------------------------------------------- Utils on InteractiveImport--mkIIModule :: ModuleName -> InteractiveImport-mkIIModule = IIModule--mkIIDecl :: ModuleName -> InteractiveImport-mkIIDecl = IIDecl . simpleImportDecl--iiModules :: [InteractiveImport] -> [ModuleName]-iiModules is = [m | IIModule m <- is]--iiModuleName :: InteractiveImport -> ModuleName-iiModuleName (IIModule m) = m-iiModuleName (IIDecl d)   = unLoc (ideclName d)--preludeModuleName :: ModuleName-preludeModuleName = GHC.mkModuleName "CLaSH.Prelude"--implicitPreludeImport :: InteractiveImport-implicitPreludeImport = IIDecl (simpleImportDecl preludeModuleName)--isPreludeImport :: InteractiveImport -> Bool-isPreludeImport (IIModule {}) = True-isPreludeImport (IIDecl d)    = unLoc (ideclName d) == preludeModuleName--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 (ideclQualified d1) || 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 :: String -> GHCi ()-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) -> setPrompt  $ dropWhile isSpace rest-    Right ("prompt2", rest) -> setPrompt2 $ dropWhile isSpace rest-    Right ("editor",  rest) -> setEditor  $ dropWhile isSpace rest-    Right ("stop",    rest) -> setStop    $ dropWhile isSpace rest-    _ -> case toArgs str of-         Left err -> liftIO (hPutStrLn stderr err)-         Right wds -> setOptions wds--setiCmd :: String -> GHCi ()-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 :: Bool -> GHCi ()-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)--        (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 :: [String] -> GHCi ()-setProg, setEditor, setStop :: String -> GHCi ()--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 })--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-       if all ((/= nm) . fst) old_breaks-              then printForUser (text "Breakpoint" <+> ppr nm <+>-                                 text "does not exist")-              else do-       let new_breaks = map fn old_breaks-           fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })-                      | otherwise = (i,loc)-       setGHCiState st{ breaks = new_breaks }-setStop cmd = modifyGHCiState (\st -> st { stop = cmd })--setPrompt :: String -> GHCi ()-setPrompt = setPrompt_ f err-  where-    f v st = st { prompt = v }-    err st = "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""--setPrompt2 :: String -> GHCi ()-setPrompt2 = setPrompt_ f err-  where-    f v st = st { prompt2 = v }-    err st = "syntax: :set prompt2 <prompt>, currently \"" ++ prompt2 st ++ "\""--setPrompt_ :: (String -> GHCiState -> GHCiState) -> (GHCiState -> String) -> String -> GHCi ()-setPrompt_ f err value = do-  st <- getGHCiState-  if null value-      then liftIO $ hPutStrLn stderr $ err st-      else case value of-           '\"' : _ -> case reads value of-                       [(value', xs)] | all isSpace xs ->-                           setGHCiState $ f value' st-                       _ ->-                           liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."-           _ -> setGHCiState $ f value st--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-      newDynFlags False minus_opts--packageFlagsChanged :: DynFlags -> DynFlags -> Bool-packageFlagsChanged idflags1 idflags0 =-    packageFlags idflags1 /= packageFlags idflags0 ||-    ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||-    pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||-    trustFlags idflags1 /= trustFlags idflags0--newDynFlags :: Bool -> [String] -> GHCi ()-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"-      GHC.setInteractiveDynFlags idflags1-      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..."-          GHC.setTargets []-          _ <- GHC.load LoadAllTargets-          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 :: String -> GHCi ()-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)-           , ("prompt2", setPrompt2 default_prompt2)-           , ("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-             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 :: String -> GHCi ()--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 :: String -> GHCi ()-showCmd ""   = showOptions False-showCmd "-a" = showOptions True-showCmd str = do-    st <- getGHCiState-    dflags <- getDynFlags--    let lookupCmd :: String -> Maybe (GHCi ())-        lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds--        -- (show in help?, command name, action)-        action :: String -> GHCi () -> (Bool, String, GHCi ())-        action name m = (True, name, m)--        hidden :: String -> GHCi () -> (Bool, String, GHCi ())-        hidden name m = (False, name, m)--        cmds =-            [ action "args"       $ liftIO $ putStrLn (show (GhciMonad.args st))-            , action "prog"       $ liftIO $ putStrLn (show (progname st))-            , action "prompt"     $ liftIO $ putStrLn (show (prompt st))-            , action "prompt2"    $ liftIO $ putStrLn (show (prompt2 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-            , 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-            ]--    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 :: String -> GHCi ()-showiCmd str = do-  case words str of-        ["languages"]  -> showiLanguages -- backwards compat-        ["language"]   -> showiLanguages-        ["lang"]       -> showiLanguages -- useful abbreviation-        _ -> throwGhcException (CmdLineError ("syntax:  :showi language"))--showImports :: GHCi ()-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_imp-        | any isPreludeImport (rem_ctx ++ trans_ctx) = []-        | otherwise = ["import CLaSH.Prelude -- implicit"]--      trans_comment s = s ++ " -- added automatically" :: String-  ---  liftIO $ mapM_ putStrLn (prel_imp ++ map show_one rem_ctx-                                    ++ map (trans_comment . show_one) trans_ctx)--showModules :: GHCi ()-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) graph--showBindings :: GHCi ()-showBindings = do-    bindings <- GHC.getBindings-    (insts, finsts) <- GHC.getInsts-    docs     <- mapM makeDoc (reverse bindings)-                  -- reverse so the new ones come last-    let idocs  = map GHC.pprInstanceHdr insts-        fidocs = map GHC.pprFamInst finsts-    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-    pprTT (thing, fixity, _cls_insts, _fam_insts)-      = pprTyThing thing-        $$ show_fixity-      where-        show_fixity-            | fixity == GHC.defaultFixity  = empty-            | otherwise                    = ppr fixity <+> ppr (GHC.getName thing)---printTyThing :: TyThing -> GHCi ()-printTyThing tyth = printForUser (pprTyThing tyth)--showBkptTable :: GHCi ()-showBkptTable = do-  st <- getGHCiState-  printForUser $ prettyLocations (breaks st)--showContext :: GHCi ()-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 :: GHCi ()-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 :: GHCi ()-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 :: GHCi ()-showLanguages = getDynFlags >>= liftIO . showLanguages' False--showiLanguages :: GHCi ()-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) `lang_set`-         case language dflags of-           Nothing -> Just Haskell2010-           other   -> other---- -------------------------------------------------------------------------------- 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-    :: CompletionFunc GHCi---- | 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 `isPrefixOf`) 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 :: String -> GHCi [String]-listHomeModules w = do-    g <- GHC.getModuleGraph-    let home_mods = map GHC.ms_mod_name 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":"prompt2":"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", "prompt", "prompt2", "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 :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi-wrapCompleter breakChars fun = completeWord Nothing breakChars-    $ fmap (map simpleCompletion . nubSort) . fun--wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi-wrapIdentCompleter = wrapCompleter word_break_chars--wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi-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 :: String -> GHCi ()-sprintCmd = pprintCommand False False-printCmd  = pprintCommand True False-forceCmd  = pprintCommand False True--pprintCommand :: Bool -> Bool -> String -> GHCi ()-pprintCommand bind force str = do-  pprintClosureCommand bind force str--stepCmd :: String -> GHCi ()-stepCmd arg = withSandboxOnly ":step" $ step arg-  where-  step []         = doContinue (const True) GHC.SingleStep-  step expression = runStmt expression GHC.SingleStep >> return ()--stepLocalCmd :: String -> GHCi ()-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 loc -> do-           Just md <- getCurrentBreakModule-           current_toplevel_decl <- enclosingTickSpan md loc-           doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep--stepModuleCmd :: String -> GHCi ()-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 :: Module -> SrcSpan -> GHCi 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 :: String -> GHCi ()-traceCmd arg-  = withSandboxOnly ":trace" $ tr arg-  where-  tr []         = doContinue (const True) GHC.RunAndLogSteps-  tr expression = runStmt expression GHC.RunAndLogSteps >> return ()--continueCmd :: String -> GHCi ()-continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion---- doContinue :: SingleStep -> GHCi ()-doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()-doContinue pre step = do-  runResult <- resume pre step-  _ <- afterRunStmt pre runResult-  return ()--abandonCmd :: String -> GHCi ()-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 :: String -> GHCi ()-deleteCmd argLine = withSandboxOnly ":delete" $ do-   deleteSwitch $ words argLine-   where-   deleteSwitch :: [String] -> GHCi ()-   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 :: String -> GHCi ()-      deleteOneBreak str-         | all isDigit str = deleteBreak (read str)-         | otherwise = return ()--historyCmd :: String -> GHCi ()-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 :: String -> GHCi ()-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 :: String -> GHCi ()-forwardCmd arg-  | null arg        = forward 1-  | all isDigit arg = forward (read arg)-  | otherwise       = liftIO $ putStrLn "Syntax:  :back [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 :: String -> GHCi ()-breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine--breakSwitch :: [String] -> GHCi ()-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 :: Module -> [String] -> GHCi ()-breakByModule md (arg1:rest)-   | all isDigit arg1 = do  -- looks like a line number-        breakByModuleLine md (read arg1) rest-breakByModule _ _-   = breakSyntax--breakByModuleLine :: Module -> Int -> [String] -> GHCi ()-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 :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()-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 = ""-                       }-         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 breakpionts 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 :: String -> GHCi ()-whereCmd = noArgs $ do-  mstrs <- getCallStackAtCurrentBreakpoint-  case mstrs of-    Nothing -> return ()-    Just strs -> liftIO $ putStrLn (renderStack strs)---------------------------------------------------------------------------------- :list--listCmd :: String -> InputT GHCi ()-listCmd c = listCmd' c--listCmd' :: String -> InputT GHCi ()-listCmd' "" = do-   mb_span <- lift 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 :: [String] -> InputT GHCi ()-list2 [arg] | all isDigit arg = do-    imports <- GHC.getContext-    case iiModules imports of-        [] -> liftIO $ putStrLn "No module to list"-        (mn : _) -> do-          md <- lift $ 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 )-                               lift $ 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 :: Module -> Int -> InputT GHCi ()-listModuleLine modl line = do-   graph <- GHC.getModuleGraph-   let this = filter ((== modl) . GHC.ms_mod) graph-   case this of-     [] -> panic "listModuleLine"-     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 -> InputT 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--      utf8Decoded <- liftIO $ BS.useAsCStringLen output-                        $ \(p,n) -> utf8DecodeString (castPtr p) n-      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 :: Module -> GHCi 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 :: GHCi ()-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 :: GHCi ()-discardActiveBreakPoints = do-   st <- getGHCiState-   mapM_ (turnOffBreak.snd) (breaks st)-   setGHCiState $ st { breaks = [] }--deleteBreak :: Int -> GHCi ()-deleteBreak identity = do-   st <- getGHCiState-   let oldLocations    = breaks st-       (this,rest)     = partition (\loc -> fst loc == identity) oldLocations-   if null this-      then printForUser (text "Breakpoint" <+> ppr identity <+>-                         text "does not exist")-      else do-           mapM_ (turnOffBreak.snd) this-           setGHCiState $ st { breaks = rest }--turnOffBreak :: BreakLocation -> GHCi ()-turnOffBreak loc = do-  (arr, _) <- getModBreak (breakModule loc)-  hsc_env <- GHC.getSession-  liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False--getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)-getModBreak m = do-   Just mod_info <- 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 :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()-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 :: SomeException -> GHCi Bool--handler exception = do-  flushInterpBuffers-  liftIO installSignalHandlers-  ghciHandle handler (showException exception >> return False)--showException :: SomeException -> GHCi ()-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 :: GHCi a -> GHCi (Either SomeException a)-ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)--tryBool :: GHCi a -> GHCi 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 -> InputT 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
− src-bin/CLaSH/GHCi/UI/Info.hs 
@@ -1,366 +0,0 @@-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Get information on modules, expreesions, 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-    }---- | 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.-    }---- | 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 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 = ml_obj_file (ms_location (modinfoSummary mi))-                last' = modinfoLastUpdate mi-            exists <- doesFileExist fp-            if exists-                then (> last') <$> getModificationTime fp-                else return True---- | 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-    now <- liftIO getCurrentTime-    return (ModInfo m allTypes i now)---- | 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 Id -> m (Maybe (Maybe Id,SrcSpan,Type))-    getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _})-        = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))-    getTypeLHsBind _ = pure Nothing--    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's-    getTypeLHsExpr :: LHsExpr Id -> 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 (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 Id -> m (Maybe (Maybe Id,SrcSpan,Type))-    getTypeLPat (L spn pat) =-        pure (Just (getMaybeId pat,spn,hsPatType pat))-      where-        getMaybeId (VarPat (L _ vid)) = Just vid-        getMaybeId _                  = Nothing--    -- | Get ALL source spans in the source.-    listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]-    listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))-      where-        p (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/CLaSH/GHCi/UI/Monad.hs 
@@ -1,427 +0,0 @@-{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}-{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly------------------------------------------------------------------------------------- Monadery code used in InteractiveUI------ (c) The GHC Team 2005-2006-----------------------------------------------------------------------------------module CLaSH.GHCi.UI.Monad (-        GHCi(..), startGHCi,-        GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,-        GHCiOption(..), isOptionSet, setOption, unsetOption,-        Command(..),-        BreakLocation(..),-        TickArray,-        getDynFlags,--        runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,--        printForUserNeverQualify, printForUserModInfo,-        printForUser, printForUserPartWay, prettyLocations,-        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 DynFlags-import FastString-import HscTypes-import SrcLoc-import Module-import GHCi-import GHCi.RemoteTypes--import Exception-import Numeric-import Data.Array-import Data.IORef-import System.CPUTime-import System.Environment-import System.IO-import Control.Monad--import System.Console.Haskeline (CompletionFunc, InputT)-import qualified System.Console.Haskeline as Haskeline-import Control.Monad.Trans.Class-import Control.Monad.IO.Class-import Data.Map.Strict (Map)---------------------------------------------------------------------------------- GHCi monad--data GHCiState = GHCiState-     {-        progname       :: String,-        args           :: [String],-        evalWrapper    :: ForeignHValue, -- ^ of type @IO a -> IO a@-        prompt         :: String,-        prompt2        :: String,-        editor         :: String,-        stop           :: String,-        options        :: [GHCiOption],-        line_number    :: !Int,         -- ^ input line-        break_ctr      :: !Int,-        breaks         :: ![(Int, 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-        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.--        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 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--data BreakLocation-   = BreakLocation-   { breakModule :: !GHC.Module-   , breakLoc    :: !SrcSpan-   , breakTick   :: {-# UNPACK #-} !Int-   , onBreakCmd  :: String-   }--instance Eq BreakLocation where-  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&-                 breakTick loc1   == breakTick loc2--prettyLocations :: [(Int, BreakLocation)] -> SDoc-prettyLocations []   = text "No active breakpoints."-prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs--instance Outputable BreakLocation where-   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>-                if null (onBreakCmd loc)-                   then Outputable.empty-                   else doubleQuotes (text (onBreakCmd loc))--recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)-recordBreak brkLoc = do-   st <- getGHCiState-   let oldActiveBreaks = breaks st-   -- 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 = (oldCounter, brkLoc) : oldActiveBreaks-                        }-      return (False, oldCounter)--newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }--reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a-reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s--reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a-reifyGHCi f = GHCi f'-  where-    -- f' :: IORef GHCiState -> Ghc a-    f' gs = reifyGhc (f'' gs)-    -- f'' :: IORef GHCiState -> Session -> IO a-    f'' gs s = f (s, gs)--startGHCi :: GHCi a -> GHCiState -> Ghc a-startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref--instance Functor GHCi where-    fmap = liftM--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 HasGhciState m where-    getGHCiState    :: m GHCiState-    setGHCiState    :: GHCiState -> m ()-    modifyGHCiState :: (GHCiState -> GHCiState) -> m ()--instance HasGhciState GHCi where-    getGHCiState      = GHCi $ \r -> liftIO $ readIORef r-    setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s-    modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f--instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where-    getGHCiState    = lift getGHCiState-    setGHCiState    = lift . setGHCiState-    modifyGHCiState = lift . modifyGHCiState--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 Haskeline.MonadException Ghc where-  controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let-                    run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)-                    in fmap (flip unGhc s) $ f run'--instance Haskeline.MonadException GHCi where-  controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let-                    run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)-                    in fmap (flip unGHCi s) $ f run'--instance ExceptionMonad (InputT GHCi) where-  gcatch = Haskeline.catch-  gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)--isOptionSet :: GHCiOption -> GHCi Bool-isOptionSet opt- = do st <- getGHCiState-      return (opt `elem` options st)--setOption :: GHCiOption -> GHCi ()-setOption opt- = do st <- getGHCiState-      setGHCiState (st{ options = opt : filter (/= opt) (options st) })--unsetOption :: GHCiOption -> GHCi ()-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 :: SDoc -> GHCi ()-printForUserPartWay doc = do-  unqual <- GHC.getPrintUnqual-  dflags <- getDynFlags-  liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc---- | Run a single Haskell expression-runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)-runStmt expr 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 expr opts--runDecls :: String -> GHCi (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)--resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi 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--timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a-timeIt getAllocs action-  = do b <- lift $ isOptionSet ShowTiming-       if not b-          then action-          else do time1   <- liftIO $ getCPUTime-                  a <- action-                  let allocs = getAllocs a-                  time2   <- liftIO $ getCPUTime-                  dflags  <- getDynFlags-                  liftIO $ printTimes dflags allocs (time2 - time1)-                  return a--printTimes :: DynFlags -> Maybe Integer -> Integer -> IO ()-printTimes dflags mallocs psecs-   = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float-            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'-              | length n' <= 3 = n'-              | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')---------------------------------------------------------------------------------- reverting CAFs--revertCAFs :: GHCi ()-revertCAFs = do-  liftIO rts_revertCAFs-  s <- getGHCiState-  when (not (ghc_e s)) turnOffBuffering-     -- Have to turn off buffering again, because we just-     -- reverted stdout, stderr & stdin to their defaults.--foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()-        -- Make it "safe", just in case---------------------------------------------------------------------------------- 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-  nobuf <- GHC.compileExprRemote $-   "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++-       " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++-       " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"-  flush <- GHC.compileExprRemote $-   "do { System.IO.hFlush System.IO.stdout; " ++-       " System.IO.hFlush System.IO.stderr }"-  return (nobuf, flush)---- | Invoke "hFlush stdout; hFlush stderr" in the interpreter-flushInterpBuffers :: GHCi ()-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 :: GHCi ()-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 =-  GHC.compileExprRemote $-    "\\m -> System.Environment.withProgName " ++ show progname ++-    "(System.Environment.withArgs " ++ show args ++ " m)"
− src-bin/CLaSH/GHCi/UI/Tags.hs 
@@ -1,215 +0,0 @@------------------------------------------------------------------------------------ GHCi's :ctags and :etags commands------ (c) The GHC Team 2005-2007-----------------------------------------------------------------------------------{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-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 Data.Function-import Data.Maybe-import Data.Ord-import DriverPhases-import Panic-import Data.List-import Control.Monad-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 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 exresion 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 exresion 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/CLaSH/Main.hs 
@@ -1,1081 +0,0 @@-{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}-{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}------------------------------------------------------------------------------------- GHC Driver program------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module CLaSH.Main (defaultMain) where--#include "MachDeps.h"---- 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 )-#ifdef GHCI-import CLaSH.GHCi.UI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )-#endif---- Frontend plugins-#ifdef GHCI-import DynamicLoading-import Plugins-#endif-import Module           ( ModuleName )----- Various other random stuff that we need-import Config-import Constants-import HscTypes-import Packages         ( pprPackages, pprPackagesSimple, pprModuleMap )-import DriverPhases-import BasicTypes       ( failed )-import StaticFlags-import DynFlags-import ErrUtils-import FastString-import Outputable-import SrcLoc-import Util-import Panic-import UniqSupply-import MonadUtils       ( liftIO )---- Imports for --abi-hash-import LoadIface           ( loadUserInterface )-import Module              ( mkModuleName )-import Finder              ( findImportedModule, cannotFindInterface )-import TcRnMonad           ( initIfaceCheck )-import Binary              ( openBinMem, put_, fingerprintBinMem )---- Standard Haskell libraries-import System.IO-import System.Environment-import System.Exit-import System.FilePath-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe---- clash additions-import           Paths_clash_ghc-import           CLaSH.GHCi.UI (makeHDL)-import           Exception (gcatch)-import           Data.IORef (IORef, newIORef, readIORef)-import qualified Data.Version (showVersion)-import           Control.Exception (Exception(..),ErrorCall (..),throw)--import qualified GHC.LanguageExtensions as LangExt--import qualified CLaSH.Backend-import           CLaSH.Backend.SystemVerilog (SystemVerilogState)-import           CLaSH.Backend.VHDL    (VHDLState)-import           CLaSH.Backend.Verilog (VerilogState)-import           CLaSH.Driver.Types (CLaSHOpts (..), CLaSHException (..))-import           CLaSH.GHC.CLaSHFlags-import           CLaSH.Netlist.BlackBox.Types (HdlSyn (..))-import           CLaSH.Rewrite.Types (DebugLevel (..))-import           CLaSH.Util (clashLibVersion)-import           CLaSH.GHC.LoadModules (ghcLibDir)---------------------------------------------------------------------------------- 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---- | Run the Clash compiler with a given set of arguments. This is equivalent to--- simply invoking the main @clash@ binary with the same arguments.-defaultMain :: [String] -> IO ()-defaultMain = flip withArgs $ do-   initGCStatistics -- See Note [-Bsymbolic and hooks]-   hSetBuffering stdout LineBuffering-   hSetBuffering stderr LineBuffering--   -- Handle GHC-specific character encoding flags, allowing us to control how-   -- GHC produces output regardless of OS.-   env <- getEnvironment-   case lookup "GHC_CHARENC" env of-    Just "UTF-8" -> do-     hSetEncoding stdout utf8-     hSetEncoding stderr utf8-    _ -> do-     -- Avoid GHC erroring out when trying to display unhandled characters-     hSetTranslit stdout-     hSetTranslit stderr--   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do-    argv0 <- getArgs-    libDir <- ghcLibDir--    let argv1 = map (mkGeneralLocated "on the commandline") argv0-    (argv2, staticFlagWarnings) <- parseStaticFlags argv1--    r <- newIORef (CLaSHOpts { opt_dbgLevel    = DebugNone-                             , opt_inlineLimit = 20-                             , opt_specLimit   = 20-                             , opt_inlineBelow = 15-                             , opt_cleanhdl    = True-                             , opt_intWidth    = WORD_SIZE_IN_BITS-                             , opt_hdlDir      = Nothing-                             , opt_hdlSyn      = Other-                             , opt_errorExtra  = False-                             , opt_floatSupport = False-                             , opt_allowZero   = False-                             , opt_importPaths = []-                             , opt_errorInvalidCoercions = True-                             })-    (argv3, clashFlagWarnings) <- parseCLaSHFlags r argv2--    -- 2. Parse the "mode" flags (--make, --interactive etc.)-    (mode, argv4, modeFlagWarnings) <- parseModeFlags argv3--    let flagWarnings = staticFlagWarnings ++ 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-                   ShowVersion               -> showVersion-                   ShowNumVersion            -> putStrLn cProjectVersion-                   ShowOptions isInteractive -> showOptions isInteractive-        Right postStartupMode ->-            -- start our GHC session-            GHC.runGhc (Just libDir) $ do--            dflags <- GHC.getSessionDynFlags-            let dflagsExtra = foldl DynFlags.xopt_set-                                    dflags-                                    [ LangExt.TemplateHaskell-                                    , LangExt.TemplateHaskellQuotes-                                    , LangExt.DataKinds-                                    , LangExt.TypeOperators-                                    , LangExt.FlexibleContexts-                                    , LangExt.ConstraintKinds-                                    , LangExt.TypeFamilies-                                    , LangExt.BinaryLiterals-                                    , LangExt.ExplicitNamespaces-                                    , LangExt.KindSignatures-                                    , LangExt.DeriveLift-                                    , LangExt.TypeApplications-                                    , LangExt.ScopedTypeVariables-                                    , LangExt.MagicHash-                                    , LangExt.ExplicitForAll-                                    ]-                dflagsExtra1 = foldl DynFlags.xopt_unset dflagsExtra-                                     [ LangExt.ImplicitPrelude-                                     , LangExt.MonomorphismRestriction-                                     ]--                ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"-                ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"-                ghcTyLitKNPlugin   = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"-                dflagsExtra2 = dflagsExtra1-                                  { DynFlags.pluginModNames = nub $-                                      ghcTyLitNormPlugin : ghcTyLitExtrPlugin :-                                      ghcTyLitKNPlugin :-                                      DynFlags.pluginModNames dflagsExtra1-                                  }--            case postStartupMode of-                Left preLoadMode ->-                    liftIO $ do-                        case preLoadMode of-                            ShowInfo               -> showInfo dflagsExtra2-                            ShowGhcUsage           -> showGhcUsage  dflagsExtra2-                            ShowGhciUsage          -> showGhciUsage dflagsExtra2-                            PrintWithDynFlags f    -> putStrLn (f dflagsExtra2)-                Right postLoadMode ->-                    main' postLoadMode dflagsExtra2 argv4 flagWarnings r--main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]-      -> 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)-               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)-               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)-               DoVHDL          -> (CompManager, dflt_target,    LinkInMemory)-               DoVerilog       -> (CompManager, dflt_target,    LinkInMemory)-               DoSystemVerilog -> (CompManager, dflt_target,    LinkInMemory)-               _               -> (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-      dflags2  | DoInteractive <- postLoadMode = imp_qual_enabled-               | DoEval _      <- postLoadMode = imp_qual_enabled-               | otherwise                     = dflags1-        where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified--        -- 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 - e.g., for win32 platforms, backslashes are converted-     -- into forward slashes.-    normal_fileish_paths = map (normalise . 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 ()--  when (verbosity dflags6 >= 3) $ do-        liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags)---  when (dopt Opt_D_dump_mod_map dflags6) . liftIO $-    printInfoForUser (dflags6 { pprCols = 200 })-                     (pkgQual dflags6) (pprModuleMap dflags6)--  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 srcs Nothing-       DoEval exprs           -> ghciUI clashOpts srcs $ Just $ reverse exprs-       DoAbiHash              -> abiHash (map fst srcs)-       ShowPackages           -> liftIO $ showPackages dflags6-       DoFrontend f           -> doFrontend f srcs-       DoVHDL                 -> clash makeVHDL-       DoVerilog              -> clash makeVerilog-       DoSystemVerilog        -> clash makeSystemVerilog--  liftIO $ dumpFinalStats dflags6--handleCLaSHException df opts e = case fromException e of-  Just (CLaSHException sp s eM) ->-    throwOneError (mkPlainErrMsg df sp (text s $$ blankLine $$ srcInfo $$ showExtra (opt_errorExtra opts) eM))-  _ -> case fromException e of-    Just (ErrorCall msg) ->-      throwOneError (mkPlainErrMsg df noSrcSpan (text "CLaSH error call:" $$ text msg))-    _ -> case fromException e of-      Just (e' :: SourceError) -> do-        GHC.printException e'-        liftIO $ exitWith (ExitFailure 1)-      _ -> throwOneError (mkPlainErrMsg df noSrcSpan (text "Other error:" $$ text (displayException e)))-  where-    srcInfo = text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$-              text "The actual location of the error can be in a function that is inlined." $$-              text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."--    showExtra False (Just _)   =-      blankLine $$-      text "This error contains additional information, rerun with '-clash-error-extra' to show this information."-    showExtra True  (Just msg) =-      blankLine $$-      text "Additional information:" $$ blankLine $$-      text msg-    showExtra _ _ = empty---ghciUI :: IORef CLaSHOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()-#ifndef GHCI-ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use")-#else-ghciUI opts  = interactiveUI (defaultGhciSettings opts)-#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 not containing a '.' 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-                      || '.' `notElem` 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"-      _ -> 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-  | 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))--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--#ifdef GHCI-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 DoVHDL              = True-isLinkMode DoVerilog           = True-isLinkMode DoSystemVerilog     = 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],-                      [Located String])-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 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 "-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--#ifdef GHCI-   -- 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--showSupportedExtensions :: IO ()-showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions--showVersion :: IO ()-showVersion = putStrLn $ concat [ "CAES Language for Synchronous Hardware, version "-                                , Data.Version.showVersion Paths_clash_ghc.version-                                , " (using clash-lib, version: "-                                , Data.Version.showVersion clashLibVersion-                                , ")"-                                ]--showOptions :: Bool -> IO ()-showOptions isInteractive = putStr (unlines availableOptions)-    where-      availableOptions = concat [-        flagsForCompletion isInteractive,-        map ('-':) (concat [-            getFlagNames mode_flags-          , (filterUnwantedStatic . getFlagNames $ flagsStatic)-          , flagsStaticNames-          ])-        ]-      getFlagNames opts         = map flagName opts-      -- this is a hack to get rid of two unwanted entries that get listed-      -- as static flags. Hopefully this hack will disappear one day together-      -- with static flags-      filterUnwantedStatic      = filter (`notElem`["f", "fno-"])--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-  buckets <- getFastStringTable-  let (entries, longest, has_z) = countFS 0 0 0 buckets-      msg = text "FastString stats:" $$-            nest 4 (vcat [text "size:           " <+> int (length buckets),-                          text "entries:        " <+> int entries,-                          text "longest chain:  " <+> int longest,-                          text "has z-encoding: " <+> (has_z `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 will 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) <> char '%'--countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)-countFS entries longest has_z [] = (entries, longest, has_z)-countFS entries longest has_z (b:bs) =-  let-        len = length b-        longest' = max len longest-        entries' = entries + len-        has_zs = length (filter hasZEncoding b)-  in-        countFS entries' longest' (has_z + has_zs) bs--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 ()-#ifndef GHCI-doFrontend _ _ =-    throwGhcException (CmdLineError "not built for interactive use")-#else-doFrontend modname srcs = do-    hsc_env <- getSession-    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname-    frontend frontend_plugin (frontendPluginOpts (hsc_dflags hsc_env)) srcs-#endif---- -------------------------------------------------------------------------------- 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 (Trac #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 $-                          cannotFindInterface dflags modname r--  mods <- mapM find_it strs--  let get_iface modl = loadUserInterface False (text "abiHash") modl-  ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods--  bh <- openBinMem (3*1024) -- just less than a block-  put_ bh hiVersion-    -- package hashes change when the compiler version changes (for now)-    -- see #5328-  mapM_ (put_ bh . mi_mod_hash) ifaces-  f <- fingerprintBinMem bh--  putStrLn (showPpr dflags f)---------------------------------------------------------------------------------- VHDL Generation--makeHDL' :: CLaSH.Backend.Backend backend => (Int -> HdlSyn -> 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 :: Int -> HdlSyn -> VHDLState)--makeVerilog ::  IORef CLaSHOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (CLaSH.Backend.initBackend :: Int -> HdlSyn -> VerilogState)--makeSystemVerilog ::  IORef CLaSHOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (CLaSH.Backend.initBackend :: Int -> HdlSyn -> SystemVerilogState)---- -------------------------------------------------------------------------------- Util--unknownFlagsErr :: [String] -> a-unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs-  where-    oneError f =-        "unrecognised flag: " ++ f ++ "\n" ++-        (case fuzzyMatch f (nub allNonDeprecatedFlags) of-            [] -> ""-            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))--{- 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.--}--foreign import ccall safe "initGCStatistics"-  initGCStatistics :: IO ()
+ src-bin/Clash/GHCi/HsVersions.h view
@@ -0,0 +1,68 @@+#ifndef HSVERSIONS_H+#define HSVERSIONS_H++#if 0++IMPORTANT!  If you put extra tabs/spaces in these macro definitions,+you will screw up the layout where they are used in case expressions!++(This is cpp-dependent, of course)++#endif++/* Useful in the headers that we share with the RTS */+#define COMPILING_GHC 1++/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */+/* #include "ghc_boot_platform.h" */++/* Pull in the autoconf defines (HAVE_FOO), but don't include+ * ghcconfig.h, because that will include ghcplatform.h which has the+ * wrong platform settings for the compiler (it has the platform+ * settings for the target plat instead). */+/* #include "ghcautoconf.h" */++#define GLOBAL_VAR(name,value,ty)  \+{-# NOINLINE name #-};             \+name :: IORef (ty);                \+name = Util.global (value);++#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-};              \+name :: IORef (ty);                 \+name = Util.globalM (value);+++#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-};                                      \+name :: IORef (ty);                                         \+name = Util.sharedGlobal (value) (accessor);                \+foreign import ccall unsafe saccessor                       \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \+{-# NOINLINE name #-};                                         \+name :: IORef (ty);                                            \+name = Util.sharedGlobalM (value) (accessor);                  \+foreign import ccall unsafe saccessor                          \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));+++#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $++-- Examples:   Assuming   flagSet :: String -> m Bool+--+--    do { c   <- getChar; MASSERT( isUpper c ); ... }+--    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }+--    do { str <- getStr;  ASSERTM( flagSet str ); .. }+--    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }+--    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }+#define MASSERT(e)      ASSERT(e) return ()+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()+#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }+#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }++#endif /* HsVersions.h */
+ src-bin/Clash/GHCi/UI.hs view
@@ -0,0 +1,3847 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- 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, runDecls )+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+import GhcMonad ( modifySession )+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),+             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,+             getModuleGraph, handleSourceError )+import HsImpExp+import HsSyn+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+                  setInteractivePrintName, hsc_dflags, msObjFilePath )+import Module+import Name+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,+                  listVisibleModuleNames, pprFlag )+import IfaceSyn ( showToHeader )+import PprTyThing+import PrelNames+import RdrName ( RdrName, getGRE_NameQualifier_maybes, getRdrName )+import SrcLoc+import qualified Lexer++import StringBuffer+import Outputable hiding ( printForUser, printForUserPartWay )++-- 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++-- 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, nub,+                   partition, sort, sortBy )+import qualified Data.Set as S+import Data.Maybe+import qualified Data.Map as M+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )++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 )++-- 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.Netlist.BlackBox.Types (HdlSyn)+import           Clash.Util (clashLibVersion)+import qualified Data.Time.Clock as Clock+import qualified Paths_clash_ghc++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+        availableCommands :: [Command],+        shortHelpText     :: String,+        fullHelpText      :: String,+        defPrompt         :: PromptFunction,+        defPromptCont     :: PromptFunction+    }++defaultGhciSettings :: IORef ClashOpts -> GhciSettings+defaultGhciSettings opts =+    GhciSettings {+        availableCommands = ghciCommands opts,+        shortHelpText     = defShortHelpText,+        defPrompt         = default_prompt,+        defPromptCont     = default_prompt_cont,+        fullHelpText      = defFullHelpText+    }++ghciWelcomeMsg :: String+ghciWelcomeMsg = "CLaSHi, version " ++ Data.Version.showVersion Paths_clash_ghc.version +++                 " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion +++                 "):\nhttp://www.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),+  ("edit",      keepGoing' editFile,            completeFilename),+  ("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),+  ("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)+  ] ++ 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" +++  "   :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" +++  "   :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" +++  "   :undef <cmd>                undefine user-defined command :<cmd>\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 breakpoint\n" +++  "   :delete *                   delete 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 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>" +++                     "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 <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.+   dflags <- getDynFlags+   let dflags' = (`xopt_set` LangExt.ExtendedDefaultRules)+               . (`xopt_unset` LangExt.MonomorphismRestriction)+               $ dflags+   GHC.setInteractiveDynFlags dflags'++   lastErrLocationsRef <- liftIO $ newIORef []+   progDynFlags <- GHC.getProgramDynFlags+   _ <- GHC.setProgramDynFlags $+      progDynFlags { log_action = ghciLogAction lastErrLocationsRef }++   when (isNothing maybe_exprs) $ do+        -- Only for GHCi (not runghc and ghc -e):++        -- Turn buffering off for the compiled program's stdout/stderr+        turnOffBuffering_ nobuffering+        -- Turn buffering off for GHCi's stdout+        liftIO $ hFlush stdout+        liftIO $ hSetBuffering stdout NoBuffering+        -- We don't want the cmd line to buffer any input that might be+        -- intended for the program, so unbuffer stdin.+        liftIO $ hSetBuffering stdin NoBuffering+        liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+        -- On Unix, stdin will use the locale encoding.  The IO library+        -- doesn't do this on Windows (yet), so for now we use UTF-8,+        -- for consistency with GHC 6.10 and to make the tests work.+        liftIO $ hSetEncoding stdin utf8+#endif++   default_editor <- liftIO $ findEditor+   eval_wrapper <- mkEvalWrapper default_progname default_args+   let prelude_import = simpleImportDecl preludeModuleName+   startGHCi (runGHCi srcs maybe_exprs)+        GHCiState{ progname           = default_progname,+                   args               = default_args,+                   evalWrapper        = eval_wrapper,+                   prompt             = default_prompt,+                   prompt_cont        = default_prompt_cont,+                   stop               = default_stop,+                   editor             = default_editor,+                   options            = [],+                   -- 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             = [],+                   tickarrays         = emptyModuleEnv,+                   ghci_commands      = availableCommands config,+                   ghci_macros        = [],+                   last_command       = Nothing,+                   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 ()++resetLastErrorLocations :: GHCi ()+resetLastErrorLocations = do+    st <- getGHCiState+    liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: IORef [(FastString, Int)] ->  LogAction+ghciLogAction lastErrLocations dflags flag severity srcSpan style msg = do+    defaultLogAction 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++   current_dir = return (Just ".clashi")++   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++  dot_cfgs <- if ignore_dot_ghci then return [] else do+    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]+    liftIO $ filterM checkFileAndDirPerms dot_files+  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs++  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 $ (catMaybes mdot_cfgs) ++ arg_cfgs+    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.++  -- 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+            -- enter the interactive loop+            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+        Just exprs -> do+            -- just evaluate the expression we were given+            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 Trac #7962+                _ <- runCommands' hdle+                     (Just $ hdle (toException $ ExitFailure 1) >> return ())+                     (return Nothing)+                return ()++  -- and finally, exit+  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi."++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 .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else.  I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "."  always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+  file_ok <- checkPerms file+  -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+  -- print some confusing and useless warnings in some cases (e.g. in+  -- travis). Note that we can't add a test for this, as all ghci tests should+  -- run with -ignore-dot-ghci, which means we never get here.+  if file_ok then checkPerms (getDirectory file) else return False+  where+  getDirectory f = case takeDirectory f of+    "" -> "."+    d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+  handleIO (\_ -> return False) $ do+    st <- getFileStatus file+    me <- getRealUserID+    let mode = System.Posix.fileMode st+        ok = (fileOwner st == me || fileOwner st == 0) &&+             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+             otherWriteMode /= mode `intersectFileModes` otherWriteMode+    unless ok $+      -- #8248: Improving warning to include a possible fix.+      putStrLn $ "*** WARNING: " ++ file +++                 " is writable by someone else, IGNORING!" +++                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+    return ok+#endif++incrementLineNo :: InputT GHCi ()+incrementLineNo = modifyGHCiState incLineNo+  where+    incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: Handle -> InputT GHCi (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 :: GHCi (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 = \_ _ -> do+    (context, modules_names, line) <- getInfoForPrompt++    let+        processString :: String -> GHCi SDoc+        processString ('%':'s':xs) =+            liftM2 (<>) (return modules_list) (processString xs)+            where+              modules_list = context <> modules_bit+              modules_bit = 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++    processString promptS++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 :: GHCi (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 :: Maybe String -> Bool -> GHCi ()+installInteractivePrint Nothing _  = return ()+installInteractivePrint (Just ipFun) exprmode = do+  ok <- trySuccess $ do+                (name:_) <- GHC.parseName ipFun+                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+                                      in he{hsc_IC = new_ic})+                return Succeeded++  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+             -> Maybe (GHCi ()) -- ^ Source error handler+             -> InputT GHCi (Maybe String)+             -> InputT GHCi (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  -> ghciHandle (\e -> lift $ eh e >>= return . Just) $+             handleSourceError printErrorAndFail+               (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 (Maybe Bool)++    -- command+    doCommand stmt | (':' : cmd) <- removeSpaces stmt = do+      result <- specialCommand cmd+      case result of+        True -> return Nothing+        _    -> return $ Just True++    -- 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 $ Just True+            Just ml_stmt -> do+              -- temporarily compensate line-number for multi-line input+              result <- timeIt runAllocs $ lift $+                runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+              return $ Just (runSuccess result)+        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+          result <- timeIt runAllocs $ lift $+            runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+          return $ Just (runSuccess result)++    -- 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 :: String -> InputT GHCi (Maybe String)+                    -> InputT GHCi (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 :: [String] -> GHCi ()+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 :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt stmt step = do+  dflags <- GHC.getInteractiveDynFlags+  if | GHC.isStmt dflags stmt    -> run_stmt+     | GHC.isImport dflags stmt  -> 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 stmt -> throwGhcException+       (CmdLineError "error: expecting a single import declaration")+     -- Note: `GHC.isDecl` returns False on input like+     -- `data Infix a b = a :@: b; infixl 4 :@:`+     -- and should therefore not be used here.+     | otherwise                 -> run_decl++  where+    run_import = do+      addImportToContext stmt+      return (Just (GHC.ExecComplete (Right []) 0))++    run_decl =+        do _ <- liftIO $ tryIO $ hFlushAll stdin+           m_result <- GhciMonad.runDecls stmt+           case m_result of+               Nothing     -> return Nothing+               Just result ->+                 Just <$> afterRunStmt (const True)+                            (GHC.ExecComplete (Right result) 0)++    run_stmt =+        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.runStmt stmt step+           case m_result of+               Nothing     -> return Nothing+               Just result -> Just <$> afterRunStmt (const True) result++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi 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 ::+  Maybe GHC.BreakInfo -> GHCi (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) <- breaks st,+                                  breakModule loc == md,+                                  breakTick loc == nm ]++printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()+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 :: [Name] -> GHCi ()+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 :: Name -> GHCi ()+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 <- lift $ 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 :: String -> GHCi Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: String -> GHCi (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' :: String -> GHCi (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 `isPrefixOf`) . 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++getCurrentBreakSpan :: GHCi (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 :: GHCi (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 :: GHCi (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 :: GHCi () -> String -> GHCi ()+noArgs m "" = m+noArgs _ _  = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: String -> GHCi () -> GHCi ()+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 :: String -> GHCi ()+help _ = do+    txt <- long_help `fmap` getGHCiState+    liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: Bool -> String -> InputT GHCi ()+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) -> 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+pprInfo (thing, fixity, cls_insts, fam_insts)+  =  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 :: String -> GHCi ()+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 :: String -> GHCi ()+runRun s = case toCmdArgs s of+           Left err          -> liftIO (hPutStrLn stderr err)+           Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: [String] -> String -> GHCi ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++                                       show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: String -> InputT GHCi ()+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 graph)) $+        liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+  GHC.setTargets []+  _ <- GHC.load LoadAllTargets+  lift $ 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) $+    lift $ enqueueCommands ["System.Directory.setCurrentDirectory " ++ show dir']++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+    handleSourceError (\e -> do GHC.printException e+                                return Failed) $ do+      act++-----------------------------------------------------------------------------+-- :edit++editFile :: String -> InputT GHCi ()+editFile str =+  do file <- if null str then lift 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 :: GHCi String+chooseEditFile =+  do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++     graph <- GHC.getModuleGraph+     failed_graph <- filterM hasFailed 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 :: Bool{-overwrite-} -> String -> GHCi ()+defineMacro _ (':':_) =+  liftIO $ putStrLn "macro name cannot start with a colon"+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+  if (not overwrite && macro_name `elem` defined)+        then throwGhcException (CmdLineError+                ("macro '" ++ macro_name ++ "' is already defined"))+        else do++  -- 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 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 :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool+runMacro fun s = do+  hsc_env <- GHC.getSession+  str <- liftIO $ evalStringToIOString hsc_env fun s+  enqueueCommands (lines str)+  return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: String -> GHCi ()+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 :: String -> GHCi ()+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 :: GHCi (LHsExpr RdrName)+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 body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: String -> InputT GHCi ()+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+++-----------------------------------------------------------------------------+-- :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 :: InputT GHCi a -> InputT GHCi 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 :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag+loadModule fs = timeIt (const Nothing) (loadModule' fs)++-- | @:load@ command+loadModule_ :: [FilePath] -> InputT GHCi ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: [FilePath] -> InputT GHCi ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi 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.++  -- unload first+  _ <- GHC.abandonAll+  lift discardActiveBreakPoints+  GHC.setTargets []+  _ <- GHC.load LoadAllTargets++  GHC.setTargets targets+  doLoadAndCollectInfo False LoadAllTargets++-- | @:add@ command+addModule :: [FilePath] -> InputT GHCi ()+addModule files = do+  lift revertCAFs -- always revert CAFs on load/add.+  files' <- mapM expandPath files+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+  -- 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 ()++-- | @:reload@ command+reloadModule :: String -> InputT GHCi ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+  where+    loadTargets | null m    = LoadAllTargets+                | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: String -> InputT GHCi ()+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 :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+  doCollectInfo <- lift (isOptionSet CollectInfo)++  doLoad retain_context howmuch >>= \case+    Succeeded | doCollectInfo -> do+      loaded <- getModuleGraph >>= filterM GHC.isLoaded . map GHC.ms_mod_name+      v <- mod_infos <$> getGHCiState+      !newInfos <- collectInfo v loaded+      modifyGHCiState (\st -> st { mod_infos = newInfos })+      return Succeeded+    flag -> return flag++doLoad :: Bool -> LoadHowMuch -> InputT GHCi 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.+  lift discardActiveBreakPoints++  lift 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 :: SuccessFlag+          -> Bool   -- keep the remembered_ctx, as far as possible (:reload)+          -> InputT GHCi ()+afterLoad ok retain_context = do+  lift revertCAFs  -- always revert CAFs on load.+  lift discardTickArrays+  loaded_mods <- getLoadedModules+  modulesLoadedMsg ok loaded_mods+  lift $ setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()+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' = flattenSCCs (GHC.topSortModuleGraph True ms 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+        :: Bool                 -- True  <=> keep all of remembered_ctx+                                -- False <=> just keep package imports+        -> [InteractiveImport]  -- new context+        -> GHCi ()++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 :: [InteractiveImport] -> GHCi [InteractiveImport]+keepPackageImports = filterM is_pkg_import+  where+     is_pkg_import :: InteractiveImport -> GHCi 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 :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()+modulesLoadedMsg ok mods = do+  dflags <- getDynFlags+  unqual <- GHC.getPrintUnqual+  let 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)+                       <> text " ("+                       <> text (normalise $ msObjFilePath mod)+                       <> text ")" -- fix #9887+  mod_names <- mapM mod_name mods+  let mod_commas+        | null mods = text "none."+        | otherwise = hsep (punctuate comma mod_names) <> text "."+      status = case ok of+                   Failed    -> text "Failed"+                   Succeeded -> text "Ok"++      msg = status <> text ", modules loaded:" <+> mod_commas++  when (verbosity dflags > 0) $+     liftIO $ putStrLn $ showSDocForUser dflags unqual msg+++-- | 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 -> backend)+         -> IORef ClashOpts+         -> [FilePath]+         -> InputT GHCi ()+makeHDL' backend opts lst = makeHDL backend opts =<< 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+      _                      -> []++makeHDL :: GHC.GhcMonad m+        => Clash.Backend.Backend backend+        => (Int -> HdlSyn -> backend)+        -> IORef ClashOpts+        -> [FilePath]+        -> m ()+makeHDL backend optsRef srcs = do+  dflags <- GHC.getSessionDynFlags+  liftIO $ do startTime <- Clock.getCurrentTime+              opts  <- readIORef optsRef+              let iw = opt_intWidth opts+                  fp = opt_floatSupport opts+                  syn = opt_hdlSyn opts+                  -- 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+                  opts' = opts {opt_hdlDir = maybe outputDir Just (opt_hdlDir opts)+                               ,opt_importPaths = idirs}+                  backend' = backend iw syn+              primDirs <- Clash.Backend.primDirs backend'+              forM_ srcs $ \src -> do+                (bindingsMap,tcm,tupTcm,topEntities,primMap) <-+                  generateBindings primDirs idirs (Clash.Backend.hdlKind backend') src (Just dflags)+                prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime+                let prepStartDiff = Clock.diffUTCTime prepTime startTime+                putStrLn $ "Loading dependencies took " ++ show prepStartDiff+                Clash.Driver.generateHDL bindingsMap (Just backend') primMap tcm+                  tupTcm (ghcTypeToHWType iw fp) reduceConstant topEntities opts' (startTime,prepTime)++makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VHDLState)++makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VerilogState)++makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> SystemVerilogState)++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: String -> InputT GHCi ()+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 :: String -> InputT GHCi ()+typeAtCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos      <- mod_infos <$> getGHCiState+    (info, ty) <- findType infos span' sample+    lift $ printForUserModInfo (modinfoInfo info)+                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: String -> InputT GHCi ()+usesCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos  <- mod_infos <$> getGHCiState+    uses   <- findNameUses infos span' sample+    forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: String -> InputT GHCi ()+locAtCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos    <- mod_infos <$> getGHCiState+    (_,_,sp) <- findLoc infos span' sample+    liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: String -> InputT GHCi ()+allTypesCmd _ = runExceptGhcMonad $ do+    infos <- 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)+                              (mkRealSrcLoc fs el ec)++    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+    ec = srcSpanEndCol    spn++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: Bool -> String -> InputT GHCi ()+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 :: String -> InputT GHCi 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 :: String -> InputT GHCi ()+isSafeCmd m =+    case words m of+        [s] | looksLikeModuleName s -> do+            md <- lift $ lookupModule s+            isSafeModule md+        [] -> do md <- guessCurrentModule "issafe"+                 isSafeModule md+        _ -> throwGhcException (CmdLineError "syntax:  :issafe <module>")++isSafeModule :: Module -> InputT GHCi ()+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 :: Bool -> String -> InputT GHCi ()+browseCmd bang m =+  case words m of+    ['*':s] | looksLikeModuleName s -> do+        md <- lift $ wantInterpretedModule s+        browseModule bang md False+    [s] | looksLikeModuleName s -> do+        md <- lift $ lookupModule s+        browseModule bang md True+    [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+             browseModule bang md True+    _ -> throwGhcException (CmdLineError "syntax:  :browse <module>")++guessCurrentModule :: String -> InputT GHCi 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 :: Bool -> Module -> Bool -> InputT GHCi ()+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 :: String -> GHCi ()+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 :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+   addModulesToContext_ starred unstarred++addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()+addModulesToContext_ starred unstarred = do+   mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+   setGHCContextFromGHCiState++remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()+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 :: ModuleName -> GHCi ()+   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 :: [ModuleName] -> [ModuleName] -> GHCi ()+setContext starred unstarred = restoreContextOnFailure $ do+  modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+                                -- delete the transient context+  addModulesToContext_ starred unstarred++addImportToContext :: String -> GHCi ()+addImportToContext str = restoreContextOnFailure $ do+  idecl <- GHC.parseImportDecl str+  addII (IIDecl idecl)   -- #5836+  setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: InteractiveImport -> GHCi ()+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 :: GHCi a -> GHCi 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 :: InteractiveImport -> GHCi ()+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 :: GHCi ()+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 :: [InteractiveImport] -> GHCi [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 RdrName -> 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 (ideclQualified d1) || 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 :: String -> GHCi ()+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+    _ -> case toArgs str of+         Left err -> liftIO (hPutStrLn stderr err)+         Right wds -> setOptions wds++setiCmd :: String -> GHCi ()+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 :: Bool -> GHCi ()+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)++        (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 :: [String] -> GHCi ()+setProg, setEditor, setStop :: String -> GHCi ()++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 })++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+       if all ((/= nm) . fst) old_breaks+              then printForUser (text "Breakpoint" <+> ppr nm <+>+                                 text "does not exist")+              else do+       let new_breaks = map fn old_breaks+           fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })+                      | otherwise = (i,loc)+       setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: PromptFunction -> GHCi ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: PromptFunction -> GHCi ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()+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 :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()+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 :: (PromptFunction -> GHCi ()) ->  String -> GHCi ()+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 :: Bool -> [String] -> GHCi ()+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"+      GHC.setInteractiveDynFlags idflags1+      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..."+          GHC.setTargets []+          _ <- GHC.load LoadAllTargets+          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 :: String -> GHCi ()+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 :: String -> GHCi ()++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 :: String -> GHCi ()+showCmd ""   = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+    st <- getGHCiState+    dflags <- getDynFlags++    let lookupCmd :: String -> Maybe (GHCi ())+        lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++        -- (show in help?, command name, action)+        action :: String -> GHCi () -> (Bool, String, GHCi ())+        action name m = (True, name, m)++        hidden :: String -> GHCi () -> (Bool, String, GHCi ())+        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+            , 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+            ]++    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 :: String -> GHCi ()+showiCmd str = do+  case words str of+        ["languages"]  -> showiLanguages -- backwards compat+        ["language"]   -> showiLanguages+        ["lang"]       -> showiLanguages -- useful abbreviation+        _ -> throwGhcException (CmdLineError ("syntax:  :showi language"))++showImports :: GHCi ()+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 :: GHCi ()+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) graph++showBindings :: GHCi ()+showBindings = do+    bindings <- GHC.getBindings+    (insts, finsts) <- GHC.getInsts+    docs     <- mapM makeDoc (reverse bindings)+                  -- reverse so the new ones come last+    let idocs  = map GHC.pprInstanceHdr insts+        fidocs = map GHC.pprFamInst finsts+    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+    pprTT (thing, fixity, _cls_insts, _fam_insts)+      = pprTyThing showToHeader thing+        $$ show_fixity+      where+        show_fixity+            | fixity == GHC.defaultFixity  = empty+            | otherwise                    = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: TyThing -> GHCi ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++showBkptTable :: GHCi ()+showBkptTable = do+  st <- getGHCiState+  printForUser $ prettyLocations (breaks st)++showContext :: GHCi ()+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 :: GHCi ()+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 :: GHCi ()+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 :: GHCi ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHCi ()+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) `lang_set`+         case language dflags of+           Nothing -> Just Haskell2010+           other   -> other++-- -----------------------------------------------------------------------------+-- 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+    :: CompletionFunc GHCi++-- | 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 `isPrefixOf`) 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 :: String -> GHCi [String]+listHomeModules w = do+    g <- GHC.getModuleGraph+    let home_mods = map GHC.ms_mod_name 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 :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi+wrapCompleter breakChars fun = completeWord Nothing breakChars+    $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi+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 :: String -> GHCi ()+sprintCmd = pprintCommand False False+printCmd  = pprintCommand True False+forceCmd  = pprintCommand False True++pprintCommand :: Bool -> Bool -> String -> GHCi ()+pprintCommand bind force str = do+  pprintClosureCommand bind force str++stepCmd :: String -> GHCi ()+stepCmd arg = withSandboxOnly ":step" $ step arg+  where+  step []         = doContinue (const True) GHC.SingleStep+  step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: String -> GHCi ()+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 loc -> do+           Just md <- getCurrentBreakModule+           current_toplevel_decl <- enclosingTickSpan md loc+           doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: String -> GHCi ()+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 :: Module -> SrcSpan -> GHCi 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 :: String -> GHCi ()+traceCmd arg+  = withSandboxOnly ":trace" $ tr arg+  where+  tr []         = doContinue (const True) GHC.RunAndLogSteps+  tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: String -> GHCi ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++-- doContinue :: SingleStep -> GHCi ()+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()+doContinue pre step = do+  runResult <- resume pre step+  _ <- afterRunStmt pre runResult+  return ()++abandonCmd :: String -> GHCi ()+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 :: String -> GHCi ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+   deleteSwitch $ words argLine+   where+   deleteSwitch :: [String] -> GHCi ()+   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 :: String -> GHCi ()+      deleteOneBreak str+         | all isDigit str = deleteBreak (read str)+         | otherwise = return ()++historyCmd :: String -> GHCi ()+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 :: String -> GHCi ()+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 :: String -> GHCi ()+forwardCmd arg+  | null arg        = forward 1+  | all isDigit arg = forward (read arg)+  | otherwise       = liftIO $ putStrLn "Syntax:  :back [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 :: String -> GHCi ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: [String] -> GHCi ()+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 :: Module -> [String] -> GHCi ()+breakByModule md (arg1:rest)+   | all isDigit arg1 = do  -- looks like a line number+        breakByModuleLine md (read arg1) rest+breakByModule _ _+   = breakSyntax++breakByModuleLine :: Module -> Int -> [String] -> GHCi ()+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 :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()+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 = ""+                       }+         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 :: String -> GHCi ()+whereCmd = noArgs $ do+  mstrs <- getCallStackAtCurrentBreakpoint+  case mstrs of+    Nothing -> return ()+    Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: String -> InputT GHCi ()+listCmd c = listCmd' c++listCmd' :: String -> InputT GHCi ()+listCmd' "" = do+   mb_span <- lift 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 :: [String] -> InputT GHCi ()+list2 [arg] | all isDigit arg = do+    imports <- GHC.getContext+    case iiModules imports of+        [] -> liftIO $ putStrLn "No module to list"+        (mn : _) -> do+          md <- lift $ 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 )+                               lift $ 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 :: Module -> Int -> InputT GHCi ()+listModuleLine modl line = do+   graph <- GHC.getModuleGraph+   let this = filter ((== modl) . GHC.ms_mod) graph+   case this of+     [] -> panic "listModuleLine"+     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 -> InputT 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 :: Module -> GHCi 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 :: GHCi ()+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 :: GHCi ()+discardActiveBreakPoints = do+   st <- getGHCiState+   mapM_ (turnOffBreak.snd) (breaks st)+   setGHCiState $ st { breaks = [] }++deleteBreak :: Int -> GHCi ()+deleteBreak identity = do+   st <- getGHCiState+   let oldLocations    = breaks st+       (this,rest)     = partition (\loc -> fst loc == identity) oldLocations+   if null this+      then printForUser (text "Breakpoint" <+> ppr identity <+>+                         text "does not exist")+      else do+           mapM_ (turnOffBreak.snd) this+           setGHCiState $ st { breaks = rest }++turnOffBreak :: BreakLocation -> GHCi ()+turnOffBreak loc = do+  (arr, _) <- getModBreak (breakModule loc)+  hsc_env <- GHC.getSession+  liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False++getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)+getModBreak m = do+   Just mod_info <- 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 :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()+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 :: SomeException -> GHCi Bool++handler exception = do+  flushInterpBuffers+  withSignalHandlers $+     ghciHandle handler (showException exception >> return False)++showException :: SomeException -> GHCi ()+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 :: GHCi a -> GHCi (Either SomeException a)+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)++tryBool :: GHCi a -> GHCi 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 -> InputT 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
+ src-bin/Clash/GHCi/UI/Info.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Get information on modules, expreesions, 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+    }++-- | 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.+    }++-- | 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 = ml_obj_file (ms_location (modinfoSummary mi))+                last' = modinfoLastUpdate mi+            exists <- doesFileExist fp+            if exists+                then (> last') <$> getModificationTime fp+                else return True++-- | 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+    now <- liftIO getCurrentTime+    return (ModInfo m allTypes i now)++-- | 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 Id -> m (Maybe (Maybe Id,SrcSpan,Type))+    getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _})+        = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))+    getTypeLHsBind _ = pure Nothing++    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+    getTypeLHsExpr :: LHsExpr Id -> 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 (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 Id -> m (Maybe (Maybe Id,SrcSpan,Type))+    getTypeLPat (L spn pat) =+        pure (Just (getMaybeId pat,spn,hsPatType pat))+      where+        getMaybeId (VarPat (L _ vid)) = Just vid+        getMaybeId _                  = Nothing++    -- | Get ALL source spans in the source.+    listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a]+    listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+      where+        p (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/Clash/GHCi/UI/Monad.hs view
@@ -0,0 +1,454 @@+{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module Clash.GHCi.UI.Monad (+        GHCi(..), startGHCi,+        GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,+        GHCiOption(..), isOptionSet, setOption, unsetOption,+        Command(..),+        PromptFunction,+        BreakLocation(..),+        TickArray,+        getDynFlags,++        runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs,++        printForUserNeverQualify, printForUserModInfo,+        printForUser, printForUserPartWay, prettyLocations,+        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 DynFlags+import FastString+import HscTypes+import SrcLoc+import Module+import GHCi+import GHCi.RemoteTypes+import HsSyn (ImportDecl)+import RdrName (RdrName)++import Exception+import Numeric+import Data.Array+import Data.IORef+import Data.Time+import System.Environment+import System.IO+import Control.Monad++import System.Console.Haskeline (CompletionFunc, InputT)+import qualified System.Console.Haskeline as Haskeline+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Data.Map.Strict (Map)++-----------------------------------------------------------------------------+-- 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,+        options        :: [GHCiOption],+        line_number    :: !Int,         -- ^ input line+        break_ctr      :: !Int,+        breaks         :: ![(Int, 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+        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 RdrName],+            -- ^ 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 RdrName],+            -- ^ 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+   }++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++data BreakLocation+   = BreakLocation+   { breakModule :: !GHC.Module+   , breakLoc    :: !SrcSpan+   , breakTick   :: {-# UNPACK #-} !Int+   , onBreakCmd  :: String+   }++instance Eq BreakLocation where+  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+                 breakTick loc1   == breakTick loc2++prettyLocations :: [(Int, BreakLocation)] -> SDoc+prettyLocations []   = text "No active breakpoints."+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs++instance Outputable BreakLocation where+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>+                if null (onBreakCmd loc)+                   then Outputable.empty+                   else doubleQuotes (text (onBreakCmd loc))++recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)+recordBreak brkLoc = do+   st <- getGHCiState+   let oldActiveBreaks = breaks st+   -- 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 = (oldCounter, brkLoc) : oldActiveBreaks+                        }+      return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a+reifyGHCi f = GHCi f'+  where+    -- f' :: IORef GHCiState -> Ghc a+    f' gs = reifyGhc (f'' gs)+    -- f'' :: IORef GHCiState -> Session -> IO a+    f'' gs s = f (s, gs)++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Functor GHCi where+    fmap = liftM++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 HasGhciState m where+    getGHCiState    :: m GHCiState+    setGHCiState    :: GHCiState -> m ()+    modifyGHCiState :: (GHCiState -> GHCiState) -> m ()++instance HasGhciState GHCi where+    getGHCiState      = GHCi $ \r -> liftIO $ readIORef r+    setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s+    modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f++instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where+    getGHCiState    = lift getGHCiState+    setGHCiState    = lift . setGHCiState+    modifyGHCiState = lift . modifyGHCiState++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 Haskeline.MonadException Ghc where+  controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+                    run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)+                    in fmap (flip unGhc s) $ f run'++instance Haskeline.MonadException GHCi where+  controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+                    run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)+                    in fmap (flip unGHCi s) $ f run'++instance ExceptionMonad (InputT GHCi) where+  gcatch = Haskeline.catch+  gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)++isOptionSet :: GHCiOption -> GHCi Bool+isOptionSet opt+ = do st <- getGHCiState+      return (opt `elem` options st)++setOption :: GHCiOption -> GHCi ()+setOption opt+ = do st <- getGHCiState+      setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GHCiOption -> GHCi ()+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 :: SDoc -> GHCi ()+printForUserPartWay doc = do+  unqual <- GHC.getPrintUnqual+  dflags <- getDynFlags+  liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc++-- | Run a single Haskell expression+runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)+runStmt expr 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 expr opts++runDecls :: String -> GHCi (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)++resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi 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++timeIt :: (a -> Maybe Integer) -> InputT GHCi a -> InputT GHCi a+timeIt getAllocs action+  = do b <- lift $ isOptionSet ShowTiming+       if not b+          then action+          else do time1   <- liftIO $ getCurrentTime+                  a <- action+                  let allocs = getAllocs a+                  time2   <- liftIO $ getCurrentTime+                  dflags  <- getDynFlags+                  let period = time2 `diffUTCTime` time1+                  liftIO $ printTimes dflags allocs (realToFrac period)+                  return a++printTimes :: DynFlags -> Maybe Integer -> Double -> IO ()+printTimes dflags mallocs 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'+              | length n' <= 3 = n'+              | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GHCi ()+revertCAFs = do+  liftIO rts_revertCAFs+  s <- getGHCiState+  when (not (ghc_e s)) turnOffBuffering+     -- Have to turn off buffering again, because we just+     -- reverted stdout, stderr & stdin to their defaults.++foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()+        -- Make it "safe", just in case++-----------------------------------------------------------------------------+-- 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+  nobuf <- GHC.compileExprRemote $+   "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " +++       " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " +++       " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"+  flush <- GHC.compileExprRemote $+   "do { System.IO.hFlush System.IO.stdout; " +++       " System.IO.hFlush System.IO.stderr }"+  return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GHCi ()+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 :: GHCi ()+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 =+  GHC.compileExprRemote $+    "\\m -> System.Environment.withProgName " ++ show progname +++    "(System.Environment.withArgs " ++ show args ++ " m)"
+ src-bin/Clash/GHCi/UI/Tags.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+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 Data.Function+import Data.Maybe+import Data.Ord+import DriverPhases+import Panic+import Data.List+import Control.Monad+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 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 exresion 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 exresion 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/Clash/Main.hs view
@@ -0,0 +1,1088 @@+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Clash.Main (defaultMain) where++-- For Int/Word size+#include "MachDeps.h"++-- 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(GHCI)+import Clash.GHCi.UI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++-- Frontend plugins+#if defined(GHCI)+import DynamicLoading   ( loadFrontendPlugin )+import Plugins+#else+import DynamicLoading   ( pluginError )+#endif+import Module           ( ModuleName )+++-- Various other random stuff that we need+import Config+import Constants+import HscTypes+import Packages         ( pprPackages, pprPackagesSimple )+import DriverPhases+import BasicTypes       ( failed )+import DynFlags+import ErrUtils+import FastString+import Outputable+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 Data.Char+import Data.List+import Data.Maybe++-- clash additions+import           Paths_clash_ghc+import           Clash.GHCi.UI (makeHDL)+import           Exception (gcatch)+import           Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Version (showVersion)+import           Control.Exception (Exception(..),ErrorCall (..))++import qualified GHC.LanguageExtensions as LangExt+import           GHC.Exception ( SomeException )++import qualified Clash.Backend+import           Clash.Backend.SystemVerilog (SystemVerilogState)+import           Clash.Backend.VHDL    (VHDLState)+import           Clash.Backend.Verilog (VerilogState)+import           Clash.Driver.Types+  (ClashOpts (..), ClashException (..), DebugLevel (..))+import           Clash.GHC.ClashFlags+import           Clash.Netlist.BlackBox.Types (HdlSyn (..))+import           Clash.Util (clashLibVersion)+import           Clash.GHC.LoadModules (ghcLibDir)++-----------------------------------------------------------------------------+-- 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++   -- Handle GHC-specific character encoding flags, allowing us to control how+   -- GHC produces output regardless of OS.+   env <- getEnvironment+   case lookup "GHC_CHARENC" env of+    Just "UTF-8" -> do+     hSetEncoding stdout utf8+     hSetEncoding stderr utf8+    _ -> do+     -- Avoid GHC erroring out when trying to display unhandled characters+     hSetTranslit stdout+     hSetTranslit stderr++   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+    argv0 <- getArgs+    libDir <- ghcLibDir++    let argv1 = map (mkGeneralLocated "on the commandline") argv0+    r <- newIORef (ClashOpts { opt_dbgLevel    = DebugNone+                             , opt_inlineLimit = 20+                             , opt_specLimit   = 20+                             , opt_inlineFunctionLimit = 15+                             , opt_inlineConstantLimit = 0+                             , opt_cachehdl    = True+                             , opt_cleanhdl    = True+                             , opt_intWidth    = WORD_SIZE_IN_BITS+                             , opt_hdlDir      = Nothing+                             , opt_hdlSyn      = Other+                             , opt_errorExtra  = False+                             , opt_floatSupport = False+                             , opt_allowZero   = False+                             , opt_importPaths = []+                             })+    (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+                   ShowVersion               -> showVersion+                   ShowNumVersion            -> putStrLn cProjectVersion+                   ShowOptions isInteractive -> showOptions isInteractive+        Right postStartupMode ->+            -- start our GHC session+            GHC.runGhc (Just libDir) $ do++            dflags <- GHC.getSessionDynFlags+            let dflagsExtra = foldl DynFlags.xopt_set+                                    dflags+                                    [ LangExt.TemplateHaskell+                                    , LangExt.TemplateHaskellQuotes+                                    , LangExt.DataKinds+                                    , LangExt.MonoLocalBinds+                                    , LangExt.TypeOperators+                                    , LangExt.FlexibleContexts+                                    , LangExt.ConstraintKinds+                                    , LangExt.TypeFamilies+                                    , LangExt.BinaryLiterals+                                    , LangExt.ExplicitNamespaces+                                    , LangExt.KindSignatures+                                    , LangExt.DeriveLift+                                    , LangExt.TypeApplications+                                    , LangExt.ScopedTypeVariables+                                    , LangExt.MagicHash+                                    , LangExt.ExplicitForAll+                                    ]+                dflagsExtra1 = foldl DynFlags.xopt_unset dflagsExtra+                                     [ LangExt.ImplicitPrelude+                                     , LangExt.MonomorphismRestriction+                                     ]++                ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+                ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+                ghcTyLitKNPlugin   = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+                dflagsExtra2 = dflagsExtra1+                                  { DynFlags.pluginModNames = nub $+                                      ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+                                      ghcTyLitKNPlugin :+                                      DynFlags.pluginModNames dflagsExtra1+                                  }++            case postStartupMode of+                Left preLoadMode ->+                    liftIO $ do+                        case preLoadMode of+                            ShowInfo               -> showInfo dflagsExtra2+                            ShowGhcUsage           -> showGhcUsage  dflagsExtra2+                            ShowGhciUsage          -> showGhciUsage dflagsExtra2+                            PrintWithDynFlags f    -> putStrLn (f dflagsExtra2)+                Right postLoadMode ->+                    main' postLoadMode dflagsExtra2 argv3 flagWarnings r++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]+      -> 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, dflt_target,    LinkInMemory)+               DoVerilog       -> (CompManager, dflt_target,    LinkInMemory)+               DoSystemVerilog -> (CompManager, dflt_target,    LinkInMemory)+               _               -> (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+      dflags2  | DoInteractive <- postLoadMode = imp_qual_enabled+               | DoEval _      <- postLoadMode = imp_qual_enabled+               | otherwise                     = dflags1+        where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified++        -- 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 - e.g., for win32 platforms, backslashes are converted+     -- into forward slashes.+    normal_fileish_paths = map (normalise . 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 srcs Nothing+       DoEval exprs           -> ghciUI clashOpts srcs $ Just $ reverse exprs+       DoAbiHash              -> abiHash (map fst srcs)+       ShowPackages           -> liftIO $ showPackages dflags6+       DoFrontend f           -> doFrontend f srcs+       DoVHDL                 -> clash makeVHDL+       DoVerilog              -> clash makeVerilog+       DoSystemVerilog        -> clash makeSystemVerilog+       DoBackpack             -> doBackpack (map fst srcs)++  liftIO $ dumpFinalStats dflags6++handleClashException+  :: GhcMonad m+  => DynFlags+  -> ClashOpts+  -> SomeException+  -> m a+handleClashException df opts e = case fromException e of+  Just (ClashException sp s eM) ->+    throwOneError (mkPlainErrMsg df sp (text s $$ blankLine $$ srcInfo $$ showExtra (opt_errorExtra opts) eM))+  _ -> case fromException e of+    Just (ErrorCall msg) ->+      throwOneError (mkPlainErrMsg df noSrcSpan (text "Clash error call:" $$ text msg))+    _ -> case fromException e of+      Just (e' :: SourceError) -> do+        GHC.printException e'+        liftIO $ exitWith (ExitFailure 1)+      _ -> throwOneError (mkPlainErrMsg df noSrcSpan (text "Other error:" $$ text (displayException e)))+  where+    srcInfo = text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$+              text "The actual location of the error can be in a function that is inlined." $$+              text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."++    showExtra False (Just _)   =+      blankLine $$+      text "This error contains additional information, rerun with '-fclash-error-extra' to show this information."+    showExtra True  (Just msg) =+      blankLine $$+      text "Additional information:" $$ blankLine $$+      text msg+    showExtra _ _ = empty++ghciUI :: IORef ClashOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()+#if !defined(GHCI)+ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI opts  = interactiveUI (defaultGhciSettings opts)+#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"+      _ -> 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(GHCI)+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 DoVHDL              = True+isLinkMode DoVerilog           = True+isLinkMode DoSystemVerilog     = 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],+                      [Located String])+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 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(GHCI)+   -- 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++showSupportedExtensions :: IO ()+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions++showVersion :: IO ()+showVersion = putStrLn $ concat [ "CLaSH, version "+                                , Data.Version.showVersion Paths_clash_ghc.version+                                , " (using clash-lib, version: "+                                , Data.Version.showVersion clashLibVersion+                                , ")"+                                ]++showOptions :: Bool -> IO ()+showOptions isInteractive = putStr (unlines availableOptions)+    where+      availableOptions = concat [+        flagsForCompletion isInteractive,+        map ('-':) (getFlagNames mode_flags)+        ]+      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+  buckets <- getFastStringTable+  let (entries, longest, has_z) = countFS 0 0 0 buckets+      msg = text "FastString stats:" $$+            nest 4 (vcat [text "size:           " <+> int (length buckets),+                          text "entries:        " <+> int entries,+                          text "longest chain:  " <+> int longest,+                          text "has z-encoding: " <+> (has_z `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 will 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) <> char '%'++countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int)+countFS entries longest has_z [] = (entries, longest, has_z)+countFS entries longest has_z (b:bs) =+  let+        len = length b+        longest' = max len longest+        entries' = entries + len+        has_zs = length (filter hasZEncoding b)+  in+        countFS entries' longest' (has_z + has_zs) bs++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 ()+#if !defined(GHCI)+doFrontend modname _ = pluginError [modname]+#else+doFrontend modname srcs = do+    hsc_env <- getSession+    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname+    frontend frontend_plugin+      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs+#endif++-- -----------------------------------------------------------------------------+-- 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 (Trac #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) ifaces+  f <- fingerprintBinMem bh++  putStrLn (showPpr dflags f)++-----------------------------------------------------------------------------+-- VHDL Generation++makeHDL' :: Clash.Backend.Backend backend => (Int -> HdlSyn -> 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 :: Int -> HdlSyn -> VHDLState)++makeVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> VerilogState)++makeSystemVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()+makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> 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.+-}++foreign import ccall safe "initGCStatistics"+  initGCStatistics :: IO ()
src-ghc/Batch.hs view
@@ -10,7 +10,7 @@   ) where  import           System.Environment ( getArgs )-import           CLaSH.Main         ( defaultMain )+import           Clash.Main         ( defaultMain )  main :: IO () main = getArgs >>= defaultMain
− src-ghc/CLaSH/GHC/CLaSHFlags.hs 
@@ -1,111 +0,0 @@-{-|-  Copyright   :  (C) 2015-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE TupleSections #-}--module CLaSH.GHC.CLaSHFlags-  ( parseCLaSHFlags-  )-where--import CmdLineParser-import Panic-import SrcLoc--import Data.IORef-import Control.Monad-import CLaSH.Driver.Types-import CLaSH.Netlist.BlackBox.Types (HdlSyn (..))-import Text.Read (readMaybe)--parseCLaSHFlags :: IORef CLaSHOpts -> [Located String]-                -> IO ([Located String],[Located String])-parseCLaSHFlags r = parseCLaSHFlagsFull (flagsClash r)--parseCLaSHFlagsFull :: [Flag IO] -> [Located String]-                    -> IO ([Located String],[Located String])-parseCLaSHFlagsFull flagsAvialable args = do-  (leftovers,errs,warns) <- processArgs flagsAvialable args--  unless (null errs) $ throwGhcExceptionIO $-    errorsToGhcException . map (("on the commandline", ) . unLoc) $ errs--  return (leftovers, warns)--flagsClash :: IORef CLaSHOpts -> [Flag IO]-flagsClash r = [-    defFlag "clash-inline-limit" (IntSuffix (liftEwM . setInlineLimit r))-  , defFlag "clash-spec-limit" (IntSuffix (liftEwM . setSpecLimit r))-  , defFlag "clash-inline-below" (IntSuffix (liftEwM . setInlineBelow r))-  , defFlag "clash-debug" (SepArg (setDebugLevel r))-  , defFlag "clash-noclean" (NoArg (liftEwM (setNoClean r)))-  , defFlag "clash-intwidth" (IntSuffix (setIntWidth r))-  , defFlag "clash-hdldir" (SepArg (setHdlDir r))-  , defFlag "clash-hdlsyn" (SepArg (setHdlSyn r))-  , defFlag "clash-error-extra" (NoArg (liftEwM (setErrorExtra r)))-  , defFlag "clash-float-support" (NoArg (liftEwM (setFloatSupport r)))-  , defFlag "clash-allow-zero-width" (NoArg (liftEwM (setAllowZeroWidth r)))-  , defFlag "clash-allow-invalid-coercions" (NoArg (liftEwM (setAllowInvalidCoercions r)))-  ]--setInlineLimit :: IORef CLaSHOpts-               -> Int-               -> IO ()-setInlineLimit r n = modifyIORef r (\c -> c {opt_inlineLimit = n})--setInlineBelow :: IORef CLaSHOpts-               -> Int-               -> IO ()-setInlineBelow r n = modifyIORef r (\c -> c {opt_inlineBelow = n})--setSpecLimit :: IORef CLaSHOpts-             -> Int-             -> IO ()-setSpecLimit r n = modifyIORef r (\c -> c {opt_specLimit = n})--setDebugLevel :: IORef CLaSHOpts-              -> String-              -> EwM IO ()-setDebugLevel r s = case readMaybe s of-  Just dbgLvl -> liftEwM $ modifyIORef r (\c -> c {opt_dbgLevel = dbgLvl})-  Nothing     -> addWarn (s ++ " is an invalid debug level")--setNoClean :: IORef CLaSHOpts -> IO ()-setNoClean r = modifyIORef r (\c -> c {opt_cleanhdl = False})--setIntWidth :: IORef CLaSHOpts-            -> Int-            -> EwM IO ()-setIntWidth r n =-  if n == 32 || n == 64-     then liftEwM $ modifyIORef r (\c -> c {opt_intWidth = n})-     else addWarn (show n ++ " is an invalid Int/Word/Integer bit-width. Allowed widths: 32, 64.")--setHdlDir :: IORef CLaSHOpts-          -> String-          -> EwM IO ()-setHdlDir r s = liftEwM $ modifyIORef r (\c -> c {opt_hdlDir = Just s})--setHdlSyn :: IORef CLaSHOpts-          -> String-          -> EwM IO ()-setHdlSyn r s = case readMaybe s of-  Just hdlSyn -> liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = hdlSyn})-  Nothing     -> if s == "Xilinx"-                    then liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = Vivado})-                    else addWarn (s ++ " is an unknown hdl synthesis tool")--setErrorExtra :: IORef CLaSHOpts -> IO ()-setErrorExtra r = modifyIORef r (\c -> c {opt_errorExtra = True})--setFloatSupport :: IORef CLaSHOpts -> IO ()-setFloatSupport r = modifyIORef r (\c -> c {opt_floatSupport = True})--setAllowZeroWidth :: IORef CLaSHOpts -> IO ()-setAllowZeroWidth r = modifyIORef r (\c -> c {opt_allowZero = True})--setAllowInvalidCoercions :: IORef CLaSHOpts -> IO ()-setAllowInvalidCoercions r = modifyIORef r (\c -> c {opt_errorInvalidCoercions = False})
− src-ghc/CLaSH/GHC/Evaluator.hs 
@@ -1,470 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente, 2017, QBayLogic-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE ViewPatterns      #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--module CLaSH.GHC.Evaluator where--import           Control.Monad.Trans.Except (runExcept)-import qualified Data.Bifunctor      as Bifunctor-import           Data.Bits           (shiftL,shiftR)-import qualified Data.Either         as Either-import qualified Data.HashMap.Strict as HashMap-import qualified Data.List           as List-import Data.Text                     (Text)-import           GHC.Real            (Ratio (..))-import           Unbound.Generics.LocallyNameless (runFreshM, bind, embed,-                                                   string2Name)--import           CLaSH.Core.DataCon  (DataCon (..))-import           CLaSH.Core.Literal  (Literal (..))-import           CLaSH.Core.Pretty   (showDoc)-import           CLaSH.Core.Term     (Term (..))-import           CLaSH.Core.Type     (Type (..), ConstTy (..), LitTy (..),-                                      TypeView (..), tyView, mkFunTy,-                                      mkTyConApp, splitFunForallTy)-import           CLaSH.Core.TyCon    (TyCon, TyConName, tyConDataCons)-import           CLaSH.Core.TysPrim  (typeNatKind)-import           CLaSH.Core.Util     (collectArgs,mkApps,mkRTree,mkVec,termType,-                                      tyNatSize)-import           CLaSH.Core.Var      (Var (..))-import           CLaSH.Util          (clogBase, flogBase, curLoc)--reduceConstant :: HashMap.HashMap TyConName TyCon -> Bool -> Term -> Term-reduceConstant tcm isSubj e@(collectArgs -> (Prim nm ty, args)) = case nm of-  "GHC.Prim.eqChar#" | Just (i,j) <- charLiterals tcm isSubj args-    -> boolToIntLiteral (i == j)--  "GHC.Prim.neChar#" | Just (i,j) <- charLiterals tcm isSubj args-    -> boolToIntLiteral (i /= j)--  "GHC.Prim.+#" | Just (i,j) <- intLiterals tcm isSubj args-    -> integerToIntLiteral (i+j)--  "GHC.Prim.-#" | Just (i,j) <- intLiterals tcm isSubj args-    -> integerToIntLiteral (i-j)--  "GHC.Prim.*#" | Just (i,j) <- intLiterals tcm isSubj args-    -> integerToIntLiteral (i*j)--  "GHC.Prim.quotInt#" | Just (i,j) <- intLiterals tcm isSubj args-    -> integerToIntLiteral (i `quot` j)--  "GHC.Prim.remInt#" | Just (i,j) <- intLiterals tcm isSubj args-    -> integerToIntLiteral (i `rem` j)--  "GHC.Prim.quotRemInt#" | Just (i,j) <- intLiterals tcm isSubj args-    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty-           (Just tupTc) = HashMap.lookup tupTcNm tcm-           [tupDc] = tyConDataCons tupTc-           (q,r)   = quotRem i j-           ret     = mkApps (Data tupDc) (map Right tyArgs ++-                    [Left (integerToIntLiteral q), Left (integerToIntLiteral r)])-       in  ret--  "GHC.Prim.negateInt#"-    | [Literal (IntLiteral i)] <- reduceTerms tcm isSubj args-    -> integerToIntLiteral (negate i)--  "GHC.Prim.>#" | Just (i,j) <- intLiterals tcm isSubj args-    -> boolToIntLiteral (i > j)--  "GHC.Prim.>=#" | Just (i,j) <- intLiterals tcm isSubj args-    -> boolToIntLiteral (i >= j)--  "GHC.Prim.==#" | Just (i,j) <- intLiterals tcm isSubj args-    -> boolToIntLiteral (i == j)--  "GHC.Prim./=#" | Just (i,j) <- intLiterals tcm isSubj args-    -> boolToIntLiteral (i /= j)--  "GHC.Prim.<#" | Just (i,j) <- intLiterals tcm isSubj args-    -> boolToIntLiteral (i < j)--  "GHC.Prim.<=#" | Just (i,j) <- intLiterals tcm isSubj args-    -> boolToIntLiteral (i <= j)--  "GHC.Prim.eqWord#" | Just (i,j) <- wordLiterals tcm isSubj args-    -> boolToIntLiteral (i == j)--  "GHC.Prim.neWord#" | Just (i,j) <- wordLiterals tcm isSubj args-    -> boolToIntLiteral (i /= j)--  "GHC.Prim.tagToEnum#"-    | [Right (ConstTy (TyCon tcN)), Left (Literal (IntLiteral i))] <--      map (Bifunctor.bimap (reduceConstant tcm isSubj) id) args-    -> let dc = do { tc <- HashMap.lookup tcN tcm-                   ; let dcs = tyConDataCons tc-                   ; List.find ((== (i+1)) . toInteger . dcTag) dcs-                   }-       in maybe e Data dc--  "GHC.Integer.Logarithms.integerLogBase#"-    | Just (a,b) <- integerLiterals tcm isSubj args-    , Just c <- flogBase a b-    -> (Literal . IntLiteral . toInteger) c--  "GHC.Integer.Type.smallInteger"-    | [Literal (IntLiteral i)] <- reduceTerms tcm isSubj args-    -> Literal (IntegerLiteral i)--  "GHC.Integer.Type.integerToInt"-    | [Literal (IntegerLiteral i)] <- reduceTerms tcm isSubj args-    -> integerToIntLiteral i--  "GHC.Integer.Type.plusInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> integerToIntegerLiteral (i+j)--  "GHC.Integer.Type.minusInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> integerToIntegerLiteral (i-j)--  "GHC.Integer.Type.timesInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> integerToIntegerLiteral (i*j)--  "GHC.Integer.Type.negateInteger#"-    | [Literal (IntegerLiteral i)] <- reduceTerms tcm isSubj args-    -> integerToIntegerLiteral (negate i)--  "GHC.Integer.Type.divInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> integerToIntegerLiteral (i `div` j)--  "GHC.Integer.Type.modInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> integerToIntegerLiteral (i `mod` j)--  "GHC.Integer.Type.quotInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> integerToIntegerLiteral (i `quot` j)--  "GHC.Integer.Type.remInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> integerToIntegerLiteral (i `rem` j)--  "GHC.Integer.Type.divModInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> let (_,tyView -> TyConApp ubTupTcNm [liftedKi,_,intTy,_]) = splitFunForallTy ty-           (Just ubTupTc) = HashMap.lookup ubTupTcNm tcm-           [ubTupDc] = tyConDataCons ubTupTc-           (d,m) = divMod i j-       in  mkApps (Data ubTupDc) [ Right liftedKi, Right liftedKi-                                 , Right intTy,    Right intTy-                                 , Left (Literal (IntegerLiteral d))-                                 , Left (Literal (IntegerLiteral m))-                                 ]--  "GHC.Integer.Type.gtInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i > j)--  "GHC.Integer.Type.geInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i >= j)--  "GHC.Integer.Type.eqInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i == j)--  "GHC.Integer.Type.neqInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i /= j)--  "GHC.Integer.Type.ltInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i < j)--  "GHC.Integer.Type.leInteger" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i <= j)--  "GHC.Integer.Type.gtInteger#" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToIntLiteral (i > j)--  "GHC.Integer.Type.geInteger#" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToIntLiteral (i >= j)--  "GHC.Integer.Type.eqInteger#" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToIntLiteral (i == j)--  "GHC.Integer.Type.neqInteger#" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToIntLiteral (i /= j)--  "GHC.Integer.Type.ltInteger#" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToIntLiteral (i < j)--  "GHC.Integer.Type.leInteger#" | Just (i,j) <- integerLiterals tcm isSubj args-    -> boolToIntLiteral (i <= j)--  "GHC.Integer.Type.shiftRInteger"-    | [Literal (IntegerLiteral i), Literal (IntLiteral j)] <- reduceTerms tcm isSubj args-    -> integerToIntegerLiteral (i `shiftR` fromInteger j)--  "GHC.Integer.Type.shiftLInteger"-    | [Literal (IntegerLiteral i), Literal (IntLiteral j)] <- reduceTerms tcm isSubj args-    -> integerToIntegerLiteral (i `shiftL` fromInteger j)--  "GHC.TypeLits.natVal"-    | [Literal (IntegerLiteral i), _] <- reduceTerms tcm isSubj args-    -> integerToIntegerLiteral i--  "GHC.Types.I#"-    | isSubj-    , [Literal (IntLiteral i)] <- reduceTerms tcm isSubj args-    ->  let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty-            (Just intTc) = HashMap.lookup intTcNm tcm-            [intDc] = tyConDataCons intTc-        in  mkApps (Data intDc) [Left (Literal (IntLiteral i))]--  "GHC.Float.$w$sfromRat''" -- XXX: Very fragile-    | [Literal (IntLiteral _minEx)-      ,Literal (IntLiteral matDigs)-      ,Literal (IntegerLiteral n)-      ,Literal (IntegerLiteral d)] <- reduceTerms tcm isSubj args-    -> case fromInteger matDigs of-          matDigs'-            | matDigs' == floatDigits (undefined :: Float)-            -> Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float)))-            | matDigs' == floatDigits (undefined :: Double)-            -> Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double)))-          _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double: " ++ showDoc e--  "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile-    | [Literal (IntLiteral _minEx)-      ,Literal (IntLiteral matDigs)-      ,Literal (IntegerLiteral n)-      ,Literal (IntegerLiteral d)] <- reduceTerms tcm isSubj args-    -> case fromInteger matDigs of-          matDigs'-            | matDigs' == floatDigits (undefined :: Float)-            -> Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float)))-            | matDigs' == floatDigits (undefined :: Double)-            -> Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double)))-          _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double: " ++ showDoc e--  "GHC.Integer.Type.doubleFromInteger"-    | [Literal (IntegerLiteral i)] <- reduceTerms tcm isSubj args-    -> Literal (DoubleLiteral (toRational (fromInteger i :: Double)))--  "GHC.Prim.double2Float#"-    | [Literal (DoubleLiteral d)] <- reduceTerms tcm isSubj args-    -> Literal (FloatLiteral (toRational (fromRational d :: Float)))--  "GHC.Prim.divideFloat#"-    | [Literal (FloatLiteral f1)-      ,Literal (FloatLiteral f2)] <- reduceTerms tcm isSubj args-    -> Literal (FloatLiteral (toRational (fromRational f1 / fromRational f2 :: Float)))--  "GHC.Base.eqString"-    | [(_,[Left (Literal (StringLiteral s1))])-      ,(_,[Left (Literal (StringLiteral s2))])-      ] <- map collectArgs (Either.lefts args)-    -> boolToBoolLiteral tcm ty (s1 == s2)--  "CLaSH.Promoted.Nat.powSNat"-    | [Right a, Right b] <- (map (runExcept . tyNatSize tcm) . Either.rights) args-    -> let c = case a of-                 2 -> 1 `shiftL` (fromInteger b)-                 _ -> a ^ b-           (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty-           (Just snatTc) = HashMap.lookup snatTcNm tcm-           [snatDc] = tyConDataCons snatTc-       in  mkApps (Data snatDc) [Right (LitTy (NumTy c)), Left (Literal (IntegerLiteral c))]--  "CLaSH.Promoted.Nat.flogBaseSNat"-    | [_,_,Right a, Right b] <- (map (runExcept . tyNatSize tcm) . Either.rights) args-    , Just c <- flogBase a b-    , let c' = toInteger c-    -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty-           (Just snatTc) = HashMap.lookup snatTcNm tcm-           [snatDc] = tyConDataCons snatTc-       in  mkApps (Data snatDc) [Right (LitTy (NumTy c')), Left (Literal (IntegerLiteral c'))]--  "CLaSH.Promoted.Nat.clogBaseSNat"-    | [_,_,Right a, Right b] <- (map (runExcept . tyNatSize tcm) . Either.rights) args-    , Just c <- clogBase a b-    , let c' = toInteger c-    -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty-           (Just snatTc) = HashMap.lookup snatTcNm tcm-           [snatDc] = tyConDataCons snatTc-       in  mkApps (Data snatDc) [Right (LitTy (NumTy c')), Left (Literal (IntegerLiteral c'))]--  "CLaSH.Promoted.Nat.logBaseSNat"-    | [_,Right a, Right b] <- (map (runExcept . tyNatSize tcm) . Either.rights) args-    , Just c <- flogBase a b-    , let c' = toInteger c-    -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty-           (Just snatTc) = HashMap.lookup snatTcNm tcm-           [snatDc] = tyConDataCons snatTc-       in  mkApps (Data snatDc) [Right (LitTy (NumTy c')), Left (Literal (IntegerLiteral c'))]--  "CLaSH.Sized.Internal.BitVector.eq#" | Just (i,j) <- bitVectorLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i == j)--  "CLaSH.Sized.Internal.BitVector.neq#" | Just (i,j) <- bitVectorLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i /= j)--  "CLaSH.Sized.Internal.Index.eq#" | Just (i,j) <- indexLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i == j)--  "CLaSH.Sized.Internal.Index.neq#" | Just (i,j) <- indexLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i /= j)--  "CLaSH.Sized.Internal.Signed.eq#" | Just (i,j) <- signedLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i == j)--  "CLaSH.Sized.Internal.Signed.neq#" | Just (i,j) <- signedLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i /= j)--  "CLaSH.Sized.Internal.Signed.minBound#"-    | [litTy,kn@(Left (Literal (IntegerLiteral mb)))] <- args-    -> let minB = negate (2 ^ (mb - 1))-       in  mkApps signedConPrim [litTy,kn,Left (Literal (IntegerLiteral minB))]--  "CLaSH.Sized.Internal.Signed.maxBound#"-    | [litTy,kn@(Left (Literal (IntegerLiteral mb)))] <- args-    -> let maxB = (2 ^ (mb - 1)) - 1-       in  mkApps signedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))]--  "CLaSH.Sized.Internal.Signed.toInteger#"-    | [collectArgs -> (Prim nm' _,[Right _, Left _, Left (Literal (IntegerLiteral i))])] <--      (map (reduceConstant tcm isSubj) . Either.lefts) args-    , nm' == "CLaSH.Sized.Internal.Signed.fromInteger#"-    -> integerToIntegerLiteral i--  "CLaSH.Sized.Internal.Unsigned.eq#" | Just (i,j) <- unsignedLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i == j)--  "CLaSH.Sized.Internal.Unsigned.neq#" | Just (i,j) <- unsignedLiterals tcm isSubj args-    -> boolToBoolLiteral tcm ty (i /= j)--  "CLaSH.Sized.Internal.Unsigned.minBound#"-    | [Right nTy] <- args-    , Right len <- runExcept (tyNatSize tcm nTy)-    -> let kn = Left (Literal (IntegerLiteral (toInteger len)))-       in  mkApps unsignedConPrim [Right nTy,kn,Left (Literal (IntegerLiteral 0))]--  "CLaSH.Sized.Internal.Unsigned.maxBound#"-    | [litTy,kn@(Left (Literal (IntegerLiteral mb)))] <- args-    -> let maxB = (2 ^ mb) - 1-       in  mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))]--  "CLaSH.Sized.Internal.Unsigned.toInteger#"-    | [collectArgs -> (Prim nm' _,[Right _, Left _, Left (Literal (IntegerLiteral i))])] <--      (map (reduceConstant tcm isSubj) . Either.lefts) args-    , nm' == "CLaSH.Sized.Internal.Unsigned.fromInteger#"-    -> integerToIntegerLiteral i--  "CLaSH.Sized.RTree.treplicate"-    | isSubj-    , (TyConApp treeTcNm [lenTy,argTy]) <- tyView (runFreshM (termType tcm e))-    , Right len <- runExcept (tyNatSize tcm lenTy)-    -> let (Just treeTc) = HashMap.lookup treeTcNm tcm-           [lrCon,brCon] = tyConDataCons treeTc-       in  mkRTree lrCon brCon argTy len (replicate (2^len) (last $ Either.lefts args))--  "CLaSH.Sized.Vector.replicate"-    | isSubj-    , (TyConApp vecTcNm [lenTy,argTy]) <- tyView (runFreshM (termType tcm e))-    , Right len <- runExcept (tyNatSize tcm lenTy)-    -> let (Just vecTc) = HashMap.lookup vecTcNm tcm-           [nilCon,consCon] = tyConDataCons vecTc-       in  mkVec nilCon consCon argTy len (replicate (fromInteger len) (last $ Either.lefts args))--  "CLaSH.Sized.Vector.maxIndex"-    | isSubj-    , [nTy, _] <- Either.rights args-    , Right n <- runExcept (tyNatSize tcm nTy)-    -> let ty' = runFreshM (termType tcm e)-           (TyConApp intTcNm _) = tyView ty'-           (Just intTc) = HashMap.lookup intTcNm tcm-           [intCon] = tyConDataCons intTc-       in  mkApps (Data intCon) [Left (Literal (IntegerLiteral (toInteger (n - 1))))]--  "CLaSH.Sized.Vector.length"-    | isSubj-    , [nTy, _] <- Either.rights args-    , Right n <-runExcept (tyNatSize tcm nTy)-    -> let ty' = runFreshM (termType tcm e)-           (TyConApp intTcNm _) = tyView ty'-           (Just intTc) = HashMap.lookup intTcNm tcm-           [intCon] = tyConDataCons intTc-       in  mkApps (Data intCon) [Left (Literal (IntegerLiteral (toInteger n)))]--  _ -> e--reduceConstant _ _ e = e--reduceTerms :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> [Term]-reduceTerms tcm isSubj = map (reduceConstant tcm isSubj) . Either.lefts--integerLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer)-integerLiterals tcm isSubj args = case reduceTerms tcm isSubj args of-  [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] -> Just (i,j)-  _ -> Nothing--intLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer)-intLiterals tcm isSubj args = case reduceTerms tcm isSubj args of-  [Literal (IntLiteral i), Literal (IntLiteral j)] -> Just (i,j)-  _ -> Nothing--wordLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer)-wordLiterals tcm isSubj args = case (map (reduceConstant tcm isSubj) . Either.lefts) args of-  [Literal (WordLiteral i), Literal (WordLiteral j)] -> Just (i,j)-  _ -> Nothing--charLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Char,Char)-charLiterals tcm isSubj args = case (map (reduceConstant tcm isSubj) . Either.lefts) args of-  [Literal (CharLiteral i), Literal (CharLiteral j)] -> Just (i,j)-  _ -> Nothing--sizedLiterals :: Text -> HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer)-sizedLiterals szCon tcm isSubj args-  = case reduceTerms tcm isSubj args of-      ([ collectArgs -> (Prim nm  _,[Right _, Left _, Left (Literal (IntegerLiteral i))])-       , collectArgs -> (Prim nm' _,[Right _, Left _, Left (Literal (IntegerLiteral j))])])-        | nm  == szCon-        , nm' == szCon -> Just (i,j)-      _ -> Nothing--bitVectorLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer)-bitVectorLiterals = sizedLiterals "CLaSH.Sized.Internal.BitVector.fromInteger#"--indexLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer)-indexLiterals = sizedLiterals "CLaSH.Sized.Internal.Index.fromInteger#"--signedLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer)-signedLiterals = sizedLiterals "CLaSH.Sized.Internal.Signed.fromInteger#"--unsignedLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer)-unsignedLiterals = sizedLiterals "CLaSH.Sized.Internal.Unsigned.fromInteger#"--boolToIntLiteral :: Bool -> Term-boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0)--boolToBoolLiteral :: HashMap.HashMap TyConName TyCon -> Type -> Bool -> Term-boolToBoolLiteral tcm ty b =- let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty-     (Just boolTc) = HashMap.lookup boolTcNm tcm-     [falseDc,trueDc] = tyConDataCons boolTc-     retDc = if b then trueDc else falseDc- in  Data retDc--integerToIntLiteral :: Integer -> Term-integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behaviour--integerToIntegerLiteral :: Integer -> Term-integerToIntegerLiteral = Literal . IntegerLiteral--signedConPrim :: Term-signedConPrim = Prim "CLaSH.Sized.Internal.Signed.fromInteger#" (ForAllTy (bind nTV funTy))-  where-    funTy      = foldr1 mkFunTy [intTy,intTy,mkTyConApp signedTcNm [nVar]]-    intTy      = ConstTy (TyCon (string2Name "GHC.Integer.Type.Integer"))-    signedTcNm = string2Name "CLaSH.Sized.Internal.Signed.Signed"-    nName      = string2Name "n"-    nVar       = VarTy typeNatKind nName-    nTV        = TyVar nName (embed typeNatKind)--unsignedConPrim :: Term-unsignedConPrim = Prim "CLaSH.Sized.Internal.Unsigned.fromInteger#" (ForAllTy (bind nTV funTy))-  where-    funTy        = foldr1 mkFunTy [intTy,intTy,mkTyConApp unsignedTcNm [nVar]]-    intTy        = ConstTy (TyCon (string2Name "GHC.Integer.Type.Integer"))-    unsignedTcNm = string2Name "CLaSH.Sized.Internal.Unsigned.Unsigned"-    nName        = string2Name "n"-    nVar         = VarTy typeNatKind nName-    nTV          = TyVar nName (embed typeNatKind)
− src-ghc/CLaSH/GHC/GHC2Core.hs 
@@ -1,745 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell  #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE ViewPatterns     #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module CLaSH.GHC.GHC2Core-  ( GHC2CoreState-  , tyConMap-  , coreToTerm-  , coreToId-  , coreToName-  , qualfiedNameString-  , makeAllTyCons-  , emptyGHC2CoreState-  )-where---- External Modules-import           Control.Exception           (throw)-import           Control.Lens                ((^.), (%~), (&), (%=))-import           Control.Monad.Trans.Class   (lift)-import           Control.Monad.Trans.Reader  (ReaderT)-import qualified Control.Monad.Trans.Reader  as Reader-import           Control.Monad.State         (State)-import qualified Control.Monad.State.Lazy    as State-import qualified Data.ByteString.Char8       as Char8-import           Data.Hashable               (Hashable (..))-import           Data.HashMap.Lazy           (HashMap)-import qualified Data.HashMap.Lazy           as HashMap-import qualified Data.HashMap.Strict         as HSM-import           Data.Maybe                  (catMaybes,fromMaybe,listToMaybe)-import           Data.Text                   (isInfixOf,pack)-import qualified Data.Traversable            as T-import           Unbound.Generics.LocallyNameless     (bind, embed, rebind, rec,-                                              runFreshM, string2Name, unbind,-                                              unembed)-import qualified Unbound.Generics.LocallyNameless     as Unbound---- GHC API-import CoAxiom    (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs),-                   fromBranches)-import Coercion   (Role(..),coercionType,coercionKind,mkCoercionType)-import CoreFVs    (exprSomeFreeVars)-import CoreSyn    (AltCon (..), Bind (..), CoreExpr,-                   Expr (..), Unfolding (..), rhssOfAlts, unfoldingTemplate)-import DataCon    (DataCon, dataConExTyVars,-                   dataConName, dataConRepArgTys,-                   dataConTag, dataConTyCon,-                   dataConUnivTyVars, dataConWorkId)-import DynFlags   (unsafeGlobalDynFlags)-import FamInstEnv (FamInst (..), FamInstEnvs,-                   familyInstances)-import FastString (unpackFS)-import Id         (isDataConId_maybe)-import IdInfo     (IdDetails (..), unfoldingInfo)-import Literal    (Literal (..))-import Module     (moduleName, moduleNameString)-import Name       (Name, nameModule_maybe,-                   nameOccName, nameUnique, getSrcSpan)-import PrelNames  (tYPETyConKey)-import OccName    (occNameString)-import Outputable (showPpr, showSDocUnsafe)-import Pair       (Pair (..))-import PprCore    (pprCoreExpr)-import SrcLoc     (isGoodSrcSpan)-import TyCon      (AlgTyConRhs (..), TyCon,-                   algTyConRhs, isAlgTyCon, isFamilyTyCon,-                   isFunTyCon, isNewTyCon,-                   isPrimTyCon, isTupleTyCon,-                   isClosedSynFamilyTyConWithAxiom_maybe,-                   expandSynTyCon_maybe,-                   tyConArity,-                   tyConDataCons, tyConKind,-                   tyConName, tyConUnique)-import Type       (mkTvSubstPrs, substTy, coreView)-import TyCoRep    (Coercion (..), TyBinder (..), TyLit (..), Type (..))-import Unique     (Uniquable (..), Unique, getKey, hasKey)-import Var        (Id, TyVar, Var, idDetails,-                   isTyVar, varName, varType,-                   varUnique, idInfo)-import VarSet     (isEmptyVarSet)---- Local imports-import qualified CLaSH.Core.DataCon          as C-import qualified CLaSH.Core.Literal          as C-import qualified CLaSH.Core.Term             as C-import qualified CLaSH.Core.TyCon            as C-import qualified CLaSH.Core.Type             as C-import qualified CLaSH.Core.Var              as C-import           CLaSH.Driver.Types-import           CLaSH.Primitives.Types-import           CLaSH.Util--instance Hashable Name where-  hashWithSalt s = hashWithSalt s . getKey . nameUnique--data GHC2CoreState-  = GHC2CoreState-  { _tyConMap :: HashMap C.TyConName TyCon-  , _nameMap  :: HashMap Name String-  }--makeLenses ''GHC2CoreState--emptyGHC2CoreState :: GHC2CoreState-emptyGHC2CoreState = GHC2CoreState HSM.empty HSM.empty--makeAllTyCons :: GHC2CoreState-              -> FamInstEnvs-              -> HashMap C.TyConName C.TyCon-makeAllTyCons hm fiEnvs = go hm hm-  where-    go old new-        | HSM.null (new ^. tyConMap) = HSM.empty-        | otherwise                  = tcm `HSM.union` tcm'-      where-        (tcm,old') = State.runState (T.mapM (makeTyCon fiEnvs) (new ^. tyConMap)) old-        tcm'       = go old' (old' & tyConMap %~ (`HSM.difference` (old ^. tyConMap)))--makeTyCon :: FamInstEnvs-          -> TyCon-          -> State GHC2CoreState C.TyCon-makeTyCon fiEnvs tc = tycon-  where-    tycon-      | isFamilyTyCon tc    = mkFunTyCon-      | isTupleTyCon tc     = mkTupleTyCon-      | isAlgTyCon tc       = mkAlgTyCon-      | isPrimTyCon tc      = mkPrimTyCon-      | tc `hasKey` tYPETyConKey = mkSuperKindTyCon-      | otherwise           = mkVoidTyCon-      where-        tcArity = tyConArity tc--        mkAlgTyCon = do-          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc-          tcKind <- coreToType (tyConKind tc)-          tcRhsM <- makeAlgTyConRhs $ algTyConRhs tc-          case tcRhsM of-            Just tcRhs ->-              return-                C.AlgTyCon-                { C.tyConName   = tcName-                , C.tyConKind   = tcKind-                , C.tyConArity  = tcArity-                , C.algTcRhs    = tcRhs-                }-            Nothing -> return (C.PrimTyCon tcName tcKind tcArity)--        mkFunTyCon = do-          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc-          tcKind <- coreToType (tyConKind tc)-          substs <- case isClosedSynFamilyTyConWithAxiom_maybe tc of-            Nothing -> let instances = familyInstances fiEnvs tc-                       in  mapM famInstToSubst instances-            Just cx -> let bx = fromBranches (co_ax_branches cx)-                       in  mapM (\b -> (,) <$> mapM coreToType (cab_lhs b)-                                           <*> coreToType (cab_rhs b))-                                bx-          return-            C.FunTyCon-            { C.tyConName  = tcName-            , C.tyConKind  = tcKind-            , C.tyConArity = tcArity-            , C.tyConSubst = substs-            }--        mkTupleTyCon = do-          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc-          tcKind <- coreToType (tyConKind tc)-          tcDc   <- fmap (C.DataTyCon . (:[])) . coreToDataCon . head . tyConDataCons $ tc-          return-            C.AlgTyCon-            { C.tyConName   = tcName-            , C.tyConKind   = tcKind-            , C.tyConArity  = tcArity-            , C.algTcRhs    = tcDc-            }--        mkPrimTyCon = do-          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc-          tcKind <- coreToType (tyConKind tc)-          return-            C.PrimTyCon-            { C.tyConName    = tcName-            , C.tyConKind    = tcKind-            , C.tyConArity   = tcArity-            }--        mkSuperKindTyCon = do-          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc-          return C.SuperKindTyCon-                   { C.tyConName = tcName-                   }--        mkVoidTyCon = do-          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc-          tcKind <- coreToType (tyConKind tc)-          return (C.PrimTyCon tcName tcKind tcArity)--        famInstToSubst :: FamInst -> State GHC2CoreState ([C.Type],C.Type)-        famInstToSubst fi = do-          tys <- mapM coreToType  (fi_tys fi)-          ty  <- coreToType (fi_rhs fi)-          return (tys,ty)--makeAlgTyConRhs :: AlgTyConRhs-                -> State GHC2CoreState (Maybe C.AlgTyConRhs)-makeAlgTyConRhs algTcRhs = case algTcRhs of-  DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs-  NewTyCon dc _ (rhsTvs,rhsEtad) _ -> Just <$> (C.NewTyCon <$> coreToDataCon dc-                                                           <*> ((,) <$> mapM coreToVar rhsTvs-                                                                    <*> coreToType rhsEtad-                                                               )-                                               )-  AbstractTyCon _ -> return Nothing-  TupleTyCon {}   -> error "Cannot handle tuple tycons"--coreToTerm :: Bool-           -> PrimMap a-           -> [Var]-           -> SrcSpan-           -> CoreExpr-           -> State GHC2CoreState C.Term-coreToTerm errorInvalidCoercions primMap unlocs srcsp coreExpr = Reader.runReaderT (term coreExpr) srcsp-  where-    term :: CoreExpr -> ReaderT SrcSpan (State GHC2CoreState) C.Term-    term (Var x)                 = do-      srcsp' <- Reader.ask-      lift (var srcsp' x)-    term (Lit l)                 = return $ C.Literal (coreToLiteral l)-    term (App eFun (Type tyArg)) = C.TyApp <$> term eFun <*> lift (coreToType tyArg)-    term (App eFun eArg)         = C.App   <$> term eFun <*> term eArg-    term (Lam x e) | isTyVar x   = C.TyLam <$> (bind <$> lift (coreToTyVar x) <*> addUsefull (getSrcSpan x) (term e))-                   | otherwise   = C.Lam   <$> (bind <$> lift (coreToId x) <*> addUsefull (getSrcSpan x) (term e))-    term (Let (NonRec x e1) e2)  = do-      x' <- lift (coreToId x)-      e1' <- addUsefull (getSrcSpan x) (term e1)-      e2' <- term e2-      return $ C.Letrec $ bind (rec [(x', embed e1')]) e2'--    term (Let (Rec xes) e) = do-      xes' <- mapM (\(x,b) -> (,) <$> lift (coreToId x)-                                  <*> addUsefull (getSrcSpan x)-                                                 (embed <$> term b))-                   xes-      e' <- term e-      return $ C.Letrec $ bind (rec xes') e'--    term (Case _ _ ty [])  = C.Prim (pack "EmptyCase") <$> lift (coreToType ty)-    term (Case e b ty alts) = do-     let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (`elem` [b]))-                  $ rhssOfAlts alts-     b' <- lift (coreToId b)-     e' <- addUsefull (getSrcSpan b) (term e)-     ty' <- lift (coreToType ty)-     let caseTerm v = C.Case v ty' <$> mapM (addUsefull (getSrcSpan b) . alt) alts-     if usesBndr-      then do-        ct <- caseTerm (C.Var (unembed $ C.varType b') (C.varName b'))-        return $ C.Letrec $ bind (rec [(b',embed e')]) ct-      else caseTerm e'--    term (Cast e co) = do-      let (Pair ty1 ty2) = coercionKind co-      hasPrimCoM <- lift (hasPrimCo co)-      ty1_I <- lift (isIntegerTy ty1)-      ty2_I <- lift (isIntegerTy ty2)-      case hasPrimCoM of-        Just ty | ty1_I || ty2_I-                , errorInvalidCoercions -> do-          sp <- Reader.ask-          throw (CLaSHException sp-                  (unlines [ "CLaSH cannot translate the following cast:\n"-                           , showSDocUnsafe (pprCoreExpr (Cast e co))-                           , "\nbecause it contains the following coercion:\n"-                           , showPpr unsafeGlobalDynFlags (if ty1_I then mkCoercionType Representational ty1 ty-                                                                    else mkCoercionType Representational ty ty2)-                           , "\nthat exposes the internal structure of the CLaSH primitive type: " ++ showPpr unsafeGlobalDynFlags ty-                           , "This is most likely due to the use of 'seq' or BangPatterns on values of (newtype wrappers of) types: {BitVector,Index,Signed,Unsigned}"-                           ])-                  (Just (unlines ["The cast occurs in the following core expression:\n"-                                 , showSDocUnsafe (pprCoreExpr coreExpr)]))-                  )--        _ -> term e-    term (Tick _ e)        = term e-    term (Type t)          = C.Prim (pack "_TY_") <$> lift (coreToType t)-    term (Coercion co)     = C.Prim (pack "_CO_") <$> lift (coreToType (coercionType co))--    var srcsp' x = do-        xVar   <- coreToVar x-        xPrim  <- coreToPrimVar x-        let xNameS = pack $ Unbound.name2String xPrim-        xType  <- coreToType (varType x)-        case isDataConId_maybe x of-          Just dc -> case HashMap.lookup xNameS primMap of-            Just _  -> return $ C.Prim xNameS xType-            Nothing -> if isDataConWrapId x && not (isNewTyCon (dataConTyCon dc))-              then let xInfo = idInfo x-                       unfolding = unfoldingInfo xInfo-                   in  case unfolding of-                          CoreUnfolding {} -> Reader.runReaderT (term (unfoldingTemplate unfolding)) srcsp'-                          NoUnfolding -> error ("No unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x)-                          _ -> error ("Unexpected unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x)-              else C.Data <$> coreToDataCon dc-          Nothing -> case HashMap.lookup xNameS primMap of-            Just (Primitive f _)-              | f == pack "CLaSH.Signal.Internal.mapSignal#" -> return (mapSignalTerm xType)-              | f == pack "CLaSH.Signal.Internal.signal#"    -> return (signalTerm xType)-              | f == pack "CLaSH.Signal.Internal.appSignal#" -> return (appSignalTerm xType)-              | f == pack "CLaSH.Signal.Internal.traverse#"  -> return (traverseTerm xType)-              | f == pack "CLaSH.Signal.Internal.joinSignal#" -> return (joinTerm xType)-              | f == pack "CLaSH.Signal.Bundle.vecBundle#"   -> return (vecUnwrapTerm xType)-              | f == pack "GHC.Base.$"                       -> return (dollarTerm xType)-              | otherwise                                    -> return (C.Prim xNameS xType)-            Just (BlackBox {}) ->-              return (C.Prim xNameS xType)-            Nothing-              | x `elem` unlocs -> return (C.Prim xNameS xType)-              | pack "$cshow" `isInfixOf` xNameS -> return (C.Prim xNameS xType)-              | otherwise       -> return  (C.Var xType xVar)--    alt (DEFAULT   , _ , e) = bind C.DefaultPat <$> term e-    alt (LitAlt l  , _ , e) = bind (C.LitPat . embed $ coreToLiteral l) <$> term e-    alt (DataAlt dc, xs, e) = case span isTyVar xs of-      (tyvs,tmvs) -> bind <$> (C.DataPat . embed <$>-                                lift (coreToDataCon dc) <*>-                                (rebind <$>-                                  lift (mapM coreToTyVar tyvs) <*>-                                  lift (mapM coreToId tmvs))) <*>-                              term e--    coreToLiteral :: Literal-                  -> C.Literal-    coreToLiteral l = case l of-      MachStr    fs  -> C.StringLiteral (Char8.unpack fs)-      MachChar   c   -> C.CharLiteral c-      MachInt    i   -> C.IntLiteral i-      MachInt64  i   -> C.IntLiteral i-      MachWord   i   -> C.WordLiteral i-      MachWord64 i   -> C.WordLiteral i-      LitInteger i _ -> C.IntegerLiteral i-      MachFloat r    -> C.FloatLiteral r-      MachDouble r   -> C.DoubleLiteral r-      MachNullAddr   -> C.StringLiteral []-      MachLabel fs _ _ -> C.StringLiteral (unpackFS fs)--addUsefull :: SrcSpan -> ReaderT SrcSpan (State GHC2CoreState) a-           -> ReaderT SrcSpan (State GHC2CoreState) a-addUsefull x = Reader.local (\r -> if isGoodSrcSpan x then x else r)--isIntegerTy :: Type -> State GHC2CoreState Bool-isIntegerTy (TyConApp tc []) = do-  tcNm <- qualfiedNameString (tyConName tc)-  return (tcNm == "GHC.Integer.Type.Integer")-isIntegerTy _ = return False--hasPrimCo :: Coercion -> State GHC2CoreState (Maybe Type)-hasPrimCo (TyConAppCo _ _ coers) = do-  tcs <- catMaybes <$> mapM hasPrimCo coers-  return (listToMaybe tcs)--hasPrimCo (AppCo co1 co2) = do-  tc1M <- hasPrimCo co1-  case tc1M of-    Just _ -> return tc1M-    _ -> hasPrimCo co2-hasPrimCo (ForAllCo _ _ co) = hasPrimCo co--hasPrimCo co@(AxiomInstCo _ _ coers) = do-    let (Pair ty1 _) = coercionKind co-    ty1PM <- isPrimTc ty1-    if ty1PM-       then return (Just ty1)-       else do-         tcs <- catMaybes <$> mapM hasPrimCo coers-         return (listToMaybe tcs)-  where-    isPrimTc (TyConApp tc _) = do-      tcNm <- qualfiedNameString (tyConName tc)-      return (tcNm `elem` ["CLaSH.Sized.Internal.BitVector.BitVector"-                          ,"CLaSH.Sized.Internal.Index.Index"-                          ,"CLaSH.Sized.Internal.Signed.Signed"-                          ,"CLaSH.Sized.Internal.Unsigned.Unsigned"-                          ])-    isPrimTc _ = return False--hasPrimCo (SymCo co) = hasPrimCo co--hasPrimCo (TransCo co1 co2) = do-  tc1M <- hasPrimCo co1-  case tc1M of-    Just _ -> return tc1M-    _ -> hasPrimCo co2--hasPrimCo (AxiomRuleCo _ coers) = do-  tcs <- catMaybes <$> mapM hasPrimCo coers-  return (listToMaybe tcs)--hasPrimCo (NthCo _ co)  = hasPrimCo co-hasPrimCo (LRCo _ co)   = hasPrimCo co-hasPrimCo (InstCo co _) = hasPrimCo co-hasPrimCo (SubCo co)    = hasPrimCo co--hasPrimCo _ = return Nothing--coreToDataCon :: DataCon-              -> State GHC2CoreState C.DataCon-coreToDataCon dc = do-    repTys <- mapM coreToType (dataConRepArgTys dc)-    dcTy   <- coreToType (varType $ dataConWorkId dc)-    mkDc dcTy repTys-  where-    mkDc dcTy repTys = do-      nm   <- coreToName dataConName getUnique qualfiedNameString dc-      uTvs <- mapM coreToVar (dataConUnivTyVars dc)-      eTvs <- mapM coreToVar (dataConExTyVars dc)-      return $ C.MkData-             { C.dcName       = nm-             , C.dcTag        = dataConTag dc-             , C.dcType       = dcTy-             , C.dcArgTys     = repTys-             , C.dcUnivTyVars = uTvs-             , C.dcExtTyVars  = eTvs-             }--coreToType :: Type-           -> State GHC2CoreState C.Type-coreToType ty = coreToType' $ fromMaybe ty (coreView ty)--coreToType' :: Type-            -> State GHC2CoreState C.Type-coreToType' (TyVarTy tv) = C.VarTy <$> coreToType (varType tv) <*> (coreToVar tv)-coreToType' (TyConApp tc args)-  | isFunTyCon tc = foldl C.AppTy (C.ConstTy C.Arrow) <$> mapM coreToType args-  | otherwise     = case expandSynTyCon_maybe tc args of-                      Just (substs,synTy,remArgs) -> do-                        let substs' = mkTvSubstPrs substs-                            synTy'  = substTy substs' synTy-                        foldl C.AppTy <$> coreToType synTy' <*> mapM coreToType remArgs-                      _ -> do-                        tcName <- coreToName tyConName tyConUnique qualfiedNameString tc-                        tyConMap %= (HSM.insert tcName tc)-                        C.mkTyConApp <$> (pure tcName) <*> mapM coreToType args-coreToType' (ForAllTy (Named tv _) ty) = C.ForAllTy <$> (bind <$> coreToTyVar tv <*> coreToType ty)-coreToType' (ForAllTy (Anon ty1) ty2)  = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2-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)-coreToType' t@(CoercionTy _) = error ("Cannot handle CoercionTy " ++ showPpr unsafeGlobalDynFlags t)--coreToTyLit :: TyLit-            -> C.LitTy-coreToTyLit (NumTyLit i) = C.NumTy (fromInteger i)-coreToTyLit (StrTyLit s) = C.SymTy (unpackFS s)--coreToTyVar :: TyVar-            -> State GHC2CoreState C.TyVar-coreToTyVar tv =-  C.TyVar <$> (coreToVar tv) <*> (embed <$> coreToType (varType tv))--coreToId :: Id-         -> State GHC2CoreState C.Id-coreToId i =-  C.Id <$> (coreToVar i) <*> (embed <$> coreToType (varType i))--coreToVar :: Var-          -> State GHC2CoreState (Unbound.Name a)-coreToVar = coreToName varName varUnique qualfiedNameStringM--coreToPrimVar :: Var-              -> State GHC2CoreState (Unbound.Name C.Term)-coreToPrimVar = coreToName varName varUnique qualfiedNameString--coreToName :: (b -> Name)-           -> (b -> Unique)-           -> (Name -> State GHC2CoreState String)-           -> b-           -> State GHC2CoreState (Unbound.Name a)-coreToName toName toUnique toString v = do-  ns <- toString (toName v)-  return (Unbound.makeName ns (toInteger . getKey . toUnique $ v))--qualfiedNameString :: Name-                   -> State GHC2CoreState String-qualfiedNameString n = makeCached n nameMap-                     $ return (fromMaybe "_INTERNAL_" (modNameM n) ++ ('.':occName))-  where-    occName = occNameString $ nameOccName n--qualfiedNameStringM :: Name-                    -> State GHC2CoreState String-qualfiedNameStringM n = makeCached n nameMap-                      $ return (maybe occName (\modName -> modName ++ ('.':occName)) (modNameM n))-  where-    occName = occNameString $ nameOccName n--modNameM :: Name-         -> Maybe String-modNameM n = do-      module_ <- nameModule_maybe n-      let moduleNm = moduleName module_-      return (moduleNameString moduleNm)---- | Given the type:------ @forall a. forall b. forall clk. (a -> b) -> Signal' clk a -> Signal' clk b@------ Generate the term:------ @--- /\(a:*)./\(b:*)./\(clk:Clock).\(f : (Signal' clk a -> Signal' clk b)).--- \(x : Signal' clk a).f x--- @-mapSignalTerm :: C.Type-              -> C.Term-mapSignalTerm (C.ForAllTy tvATy) =-    C.TyLam (bind aTV (-    C.TyLam (bind bTV (-    C.TyLam (bind clkTV (-    C.Lam   (bind fId (-    C.Lam   (bind xId (-    C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))-  where-    (aTV,bTV,clkTV,funTy) = runFreshM $ do-      { (aTV',C.ForAllTy tvBTy)   <- unbind tvATy-      ; (bTV',C.ForAllTy tvClkTy) <- unbind tvBTy-      ; (clkTV',funTy')           <- unbind tvClkTy-      ; return (aTV',bTV',clkTV',funTy')-      }-    (C.FunTy _ funTy'') = C.tyView funTy-    (C.FunTy aTy bTy)   = C.tyView funTy''-    fName = string2Name "f"-    xName = string2Name "x"-    fTy   = C.mkFunTy aTy bTy-    fId   = C.Id fName (embed fTy)-    xId   = C.Id xName (embed aTy)--mapSignalTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @forall a. forall clk. a -> Signal' clk a@------ Generate the term------ @/\(a:*)./\(clk:Clock).\(x:Signal' clk a).x@-signalTerm :: C.Type-           -> C.Term-signalTerm (C.ForAllTy tvATy) =-    C.TyLam (bind aTV (-    C.TyLam (bind clkTV (-    C.Lam   (bind xId (-    C.Var   aTy xName))))))-  where-    (aTV,clkTV,funTy) = runFreshM $ do-      { (aTV', C.ForAllTy tvClkTy) <- unbind tvATy-      ; (clkTV', funTy')           <- unbind tvClkTy-      ; return (aTV',clkTV',funTy')-      }-    (C.FunTy _ aTy) = C.tyView funTy-    xName = string2Name "x"-    xId   = C.Id xName (embed aTy)--signalTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @--- forall clk. forall a. forall b. Signal' clk (a -> b) -> Signal' clk a ->--- Signal' clk b--- @------ Generate the term:------ @--- /\(clk:Clock)./\(a:*)./\(b:*).\(f : (Signal' clk a -> Signal' clk b)).--- \(x : Signal' clk a).f x--- @-appSignalTerm :: C.Type-              -> C.Term-appSignalTerm (C.ForAllTy tvClkTy) =-    C.TyLam (bind clkTV (-    C.TyLam (bind aTV (-    C.TyLam (bind bTV (-    C.Lam   (bind fId (-    C.Lam   (bind xId (-    C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))-  where-    (clkTV,aTV,bTV,funTy) = runFreshM $ do-      { (clkTV',C.ForAllTy tvATy) <- unbind tvClkTy-      ; (aTV',C.ForAllTy tvBTy)   <- unbind tvATy-      ; (bTV',funTy')           <- unbind tvBTy-      ; return (clkTV',aTV',bTV',funTy')-      }-    (C.FunTy _ funTy'') = C.tyView funTy-    (C.FunTy aTy bTy)   = C.tyView funTy''-    fName = string2Name "f"-    xName = string2Name "x"-    fTy   = C.mkFunTy aTy bTy-    fId   = C.Id fName (embed fTy)-    xId   = C.Id xName (embed aTy)--appSignalTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @--- forall t.forall n.forall a.Vec n (Signal' t a) ->--- Signal' t (Vec n a)--- @------ Generate the term:------ @--- /\(t:Clock)./\(n:Nat)./\(a:*).\(vs:Signal' t (Vec n a)).vs--- @-vecUnwrapTerm :: C.Type-              -> C.Term-vecUnwrapTerm (C.ForAllTy tvTTy) =-    C.TyLam (bind tTV (-    C.TyLam (bind nTV (-    C.TyLam (bind aTV (-    C.Lam   (bind vsId (-    C.Var vsTy vsName))))))))-  where-    (tTV,nTV,aTV,funTy) = runFreshM $ do-      { (tTV',C.ForAllTy tvNTy) <- unbind tvTTy-      ; (nTV',C.ForAllTy tvATy) <- unbind tvNTy-      ; (aTV',funTy')           <- unbind tvATy-      ; return (tTV',nTV',aTV',funTy')-      }-    (C.FunTy _ vsTy) = C.tyView funTy-    vsName           = string2Name "vs"-    vsId             = C.Id vsName   (embed vsTy)--vecUnwrapTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @--- forall f.forall a.forall b.forall clk.Applicative f => (a -> f b) ->--- CSignal clk a -> f (Signal' clk b)--- @------ Generate the term:------ @--- /\(f:* -> *)./\(a:*)./\(b:*)./\(clk:Clock).\(dict:Applicative f).--- \(g:a -> f b).\(x:Signal' clk a).g x--- @-traverseTerm :: C.Type-             -> C.Term-traverseTerm (C.ForAllTy tvFTy) =-    C.TyLam (bind fTV (-    C.TyLam (bind aTV (-    C.TyLam (bind bTV (-    C.TyLam (bind clkTV (-    C.Lam   (bind dictId (-    C.Lam   (bind gId (-    C.Lam   (bind xId (-    C.App (C.Var gTy gName) (C.Var xTy xName)))))))))))))))-  where-    (fTV,aTV,bTV,clkTV,funTy) = runFreshM $ do-      { (fTV',C.ForAllTy tvATy) <- unbind tvFTy-      ; (aTV',C.ForAllTy tvBTy) <- unbind tvATy-      ; (bTV',C.ForAllTy tvClkTy) <- unbind tvBTy-      ; (clkTV',funTy') <- unbind tvClkTy-      ; return (fTV',aTV',bTV',clkTV',funTy')-      }-    (C.FunTy dictTy funTy1) = C.tyView funTy-    (C.FunTy gTy    funTy2) = C.tyView funTy1-    (C.FunTy xTy    _)      = C.tyView funTy2-    dictName = string2Name "dict"-    gName    = string2Name "g"-    xName    = string2Name "x"-    dictId   = C.Id dictName (embed dictTy)-    gId      = C.Id gName (embed gTy)-    xId      = C.Id xName (embed xTy)--traverseTerm ty = error $ $(curLoc) ++ show ty---- ∀ (r :: GHC.Types.RuntimeRep)---   (a :: GHC.Prim.TYPE GHC.Types.PtrRepLifted)---   (b :: GHC.Prim.TYPE r).--- (a -> b) -> a -> b----- | Given the type:------ @forall (r :: Rep) (a :: TYPE Lifted) (b :: TYPE r). (a -> b) -> a -> b@------ Generate the term:------ @/\(r:Rep)/\(a:TYPE Lifted)./\(b:TYPE r).\(f : (a -> b)).\(x : a).f x@-dollarTerm :: C.Type-           -> C.Term-dollarTerm (C.ForAllTy tvRTy) =-    C.TyLam (bind rTV (-    C.TyLam (bind aTV (-    C.TyLam (bind bTV (-    C.Lam   (bind fId (-    C.Lam   (bind xId (-    C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))-  where-    (rTV,aTV,bTV,funTy) = runFreshM $ do-      { (rTV',C.ForAllTy tvATy) <- unbind tvRTy-      ; (aTV',C.ForAllTy tvBTy) <- unbind tvATy-      ; (bTV',funTy')           <- unbind tvBTy-      ; return (rTV',aTV',bTV',funTy')-      }-    (C.FunTy fTy funTy'') = C.tyView funTy-    (C.FunTy aTy _)       = C.tyView funTy''-    fName = string2Name "f"-    xName = string2Name "x"-    fId   = C.Id fName (embed fTy)-    xId   = C.Id xName (embed aTy)--dollarTerm ty = error $ $(curLoc) ++ show ty---- | Given the type:------ @forall a. forall clk. Signal' clk (Signal' clk a) -> Signal' clk a@------ Generate the term------ @/\(a:*)./\(clk:Clock).\(x:Signal' clk a).x@-joinTerm :: C.Type-         -> C.Term-joinTerm ty@(C.ForAllTy _) = signalTerm ty-joinTerm ty = error $ $(curLoc) ++ show ty--isDataConWrapId :: Id -> Bool-isDataConWrapId v = case idDetails v of-  DataConWrapId {} -> True-  _                -> False
− src-ghc/CLaSH/GHC/GenerateBindings.hs 
@@ -1,174 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente, 2017, QBayLogic-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--module CLaSH.GHC.GenerateBindings-  (generateBindings)-where--import           Control.Lens            ((%~),(&),(^.),_1)-import           Control.Monad.State     (State)-import qualified Control.Monad.State     as State-import           Data.Either             (lefts, rights)-import           Data.HashMap.Strict     (HashMap)-import qualified Data.HashMap.Strict     as HashMap-import           Data.IntMap.Strict      (IntMap)-import qualified Data.IntMap.Strict      as IM-import           Data.Text.Lazy          (Text)-import qualified Data.Set                as Set-import qualified Data.Set.Lens           as Lens-import           Unbound.Generics.LocallyNameless (runFreshM, unembed)--import qualified BasicTypes              as GHC-import qualified CoreSyn                 as GHC-import qualified DynFlags                as GHC-import qualified Name                    as GHC hiding (varName)-import qualified TyCon                   as GHC-import qualified TysWiredIn              as GHC-import qualified Var                     as GHC-import qualified SrcLoc                  as GHC--import           CLaSH.Annotations.TopEntity (TopEntity)-import           CLaSH.Annotations.Primitive (HDL)-import           CLaSH.Core.FreeVars     (termFreeIds)-import           CLaSH.Core.Term         (Term (..), TmName)-import           CLaSH.Core.Type         (Type, TypeView (..), mkFunTy, splitFunForallTy, tyView)-import           CLaSH.Core.TyCon        (TyCon, TyConName)-import           CLaSH.Core.TysPrim      (tysPrimMap)-import           CLaSH.Core.Subst        (substTms)-import           CLaSH.Core.Util         (mkLams, mkTyLams, termType)-import           CLaSH.Core.Var          (Var (..))-import           CLaSH.Driver.Types      (BindingMap)-import           CLaSH.GHC.GHC2Core      (GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm,-                                          makeAllTyCons, qualfiedNameString, emptyGHC2CoreState)-import           CLaSH.GHC.LoadModules   (loadModules)-import           CLaSH.Normalize.Util-import           CLaSH.Primitives.Types  (PrimMap)-import           CLaSH.Primitives.Util   (generatePrimMap)-import           CLaSH.Rewrite.Util      (mkInternalVar, mkSelectorCase)-import           CLaSH.Util              ((***),first)--generateBindings ::-     Bool-  -> FilePath-  -> [FilePath]-  -> HDL-  -> String-  -> Maybe  (GHC.DynFlags)-  -> IO (BindingMap,HashMap TyConName TyCon,IntMap TyConName-        ,(TmName, Maybe TopEntity) -- topEntity bndr + (maybe) TopEntity annotation-        ,Maybe TmName              -- testInput bndr-        ,Maybe TmName              -- expectedOutput bndr-        ,PrimMap Text)             -- The primitives found in '.' and 'primDir'-generateBindings errorInvalidCoercions primDir importDirs hdl modName dflagsM = do-  (bindings,clsOps,unlocatable,fiEnvs,(topEnt,topEntAnn),testInpM,expOutM,pFP) <- loadModules hdl modName dflagsM-  primMap <- generatePrimMap (pFP ++ (primDir:importDirs))-  let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings errorInvalidCoercions primMap bindings clsOps unlocatable) emptyGHC2CoreState-      (tcMap',tupTcCache)           = mkTupTyCons tcMap-      tcCache                       = makeAllTyCons tcMap' fiEnvs-      allTcCache                    = tysPrimMap `HashMap.union` tcCache-      clsMap                        = HashMap.map (\(ty,i) -> (ty,GHC.noSrcSpan,mkClassSelector allTcCache ty i)) clsVMap-      allBindings                   = bindingsMap `HashMap.union` clsMap-      (topEnt',testInpM',expOutM')  = flip State.evalState tcMap' $ do-                                          topEnt'' <- coreToName GHC.varName GHC.varUnique qualfiedNameString topEnt-                                          testInpM'' <- traverse (coreToName GHC.varName GHC.varUnique qualfiedNameString) testInpM-                                          expOutM'' <- traverse (coreToName GHC.varName GHC.varUnique qualfiedNameString) expOutM-                                          return (topEnt'',testInpM'',expOutM'')-      droppedAndRetypedBindings     = dropAndRetypeBindings allTcCache allBindings topEnt' testInpM' expOutM'--  return (droppedAndRetypedBindings,allTcCache,tupTcCache,(topEnt',topEntAnn),testInpM',expOutM',primMap)--dropAndRetypeBindings :: HashMap TyConName TyCon-                      -> BindingMap-                      -> TmName        -- ^ topEntity-                      -> Maybe TmName  -- ^ testInput-                      -> Maybe TmName  -- ^ expectedOutput-                      -> BindingMap--dropAndRetypeBindings allTcCache allBindings topEnt testInpM expOutM = oBindings-  where-    topEntity = do e <- HashMap.lookup topEnt allBindings-                   return (topEnt,e)-    testInput = do t <- testInpM-                   e <- HashMap.lookup t allBindings-                   return (t,e)-    expectedOut = do t <- expOutM-                     e <- HashMap.lookup t allBindings-                     return (t,e)--    tBindings = maybe allBindings (dropAndRetype allBindings) topEntity-    iBindings = maybe tBindings (dropAndRetype tBindings) testInput-    oBindings = maybe iBindings (dropAndRetype iBindings) expectedOut-    dropAndRetype d (t,_) = snd (retype allTcCache ([],lambdaDropPrep d t) t)---- | clean up cast-removal mess-retype :: HashMap TyConName TyCon-       -> ([TmName], BindingMap) -- (visited, bindings)-       -> TmName                 -- top-       -> ([TmName], BindingMap)-retype tcm (visited,bindings) current = (visited', HashMap.insert current (ty',sp,tm') bindings')-  where-    (_,sp,tm)            = bindings HashMap.! current-    used                 = Set.toList $ Lens.setOf termFreeIds tm-    (visited',bindings') = foldl (retype tcm) (current:visited,bindings) (filter (`notElem` visited) used)-    usedTys              = map ((^. _1) . (bindings' HashMap.!)) used-    usedVars             = zipWith Var usedTys used-    tm'                  = substTms (zip used usedVars) tm-    ty'                  = runFreshM (termType tcm tm')--mkBindings :: Bool-           -> PrimMap a-           -> [(GHC.CoreBndr, GHC.CoreExpr)] -- Binders-           -> [(GHC.CoreBndr,Int)]           -- Class operations-           -> [GHC.CoreBndr]                 -- Unlocatable Expressions-           -> State GHC2CoreState-                    ( BindingMap-                    , HashMap TmName (Type,Int)-                    )-mkBindings errorInvalidCoercions primMap bindings clsOps unlocatable = do-  bindingsList <- mapM (\(v,e) -> do-                          let sp = GHC.getSrcSpan v-                          tm <- coreToTerm errorInvalidCoercions primMap unlocatable sp e-                          v' <- coreToId v-                          return (varName v', (unembed (varType v'), sp, tm))-                       ) bindings-  clsOpList    <- mapM (\(v,i) -> do-                          v' <- coreToId v-                          let ty = unembed $ varType v'-                          return (varName v', (ty,i))-                       ) clsOps--  return (HashMap.fromList bindingsList, HashMap.fromList clsOpList)--mkClassSelector :: HashMap TyConName TyCon-                -> Type-                -> Int-                -> Term-mkClassSelector tcm ty sel = newExpr-  where-    ((tvs,dictTy:_),_) = first (lefts *** rights)-                       $ first (span (\l -> case l of Left _ -> True-                                                      _      -> False))-                       $ splitFunForallTy ty-    newExpr = case tyView dictTy of-      (TyConApp _ _) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do-                          (dcId,dcVar) <- mkInternalVar "dict" dictTy-                          selE         <- mkSelectorCase "mkClassSelector" tcm dcVar 1 sel-                          return (mkTyLams (mkLams selE [dcId]) tvs)-      (FunTy arg res) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do-                           (dcId,dcVar) <- mkInternalVar "dict" (mkFunTy arg res)-                           return (mkTyLams (mkLams dcVar [dcId]) tvs)-      (OtherType oTy) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do-                           (dcId,dcVar) <- mkInternalVar "dict" oTy-                           return (mkTyLams (mkLams dcVar [dcId]) tvs)--mkTupTyCons :: GHC2CoreState -> (GHC2CoreState,IntMap TyConName)-mkTupTyCons tcMap = (tcMap'',tupTcCache)-  where-    tupTyCons        = map (GHC.tupleTyCon GHC.Boxed) [2..62]-    (tcNames,tcMap') = State.runState (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique qualfiedNameString tc) tupTyCons) tcMap-    tupTcCache       = IM.fromList (zip [2..62] tcNames)-    tupHM            = HashMap.fromList (zip tcNames tupTyCons)-    tcMap''          = tcMap' & tyConMap %~ (`HashMap.union` tupHM)
− src-ghc/CLaSH/GHC/LoadInterfaceFiles.hs 
@@ -1,203 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP                 #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TupleSections       #-}--module CLaSH.GHC.LoadInterfaceFiles-  (loadExternalExprs)-where---- External Modules-import           Data.Either (partitionEithers)-import           Data.List   (elemIndex, partition)-import           Data.Maybe  (isJust, isNothing, mapMaybe)-import           Data.Word   (Word8)--import           CLaSH.Annotations.Primitive---- GHC API-import qualified Annotations-import qualified BasicTypes-import qualified Class-import qualified CoreFVs-import qualified CoreSyn-import qualified Demand-import           DynFlags    (unsafeGlobalDynFlags)-import qualified GHC-import qualified Id-import qualified IdInfo-import qualified IfaceSyn-import qualified LoadIface-import qualified Maybes-import qualified MkCore-import qualified MonadUtils-import qualified Name-import           Outputable  (showPpr, showSDoc, text)-import qualified Serialized-import qualified TcIface-import qualified TcRnMonad-import qualified TcRnTypes-import qualified UniqFM-import qualified Var-import qualified VarSet---- Internal Modules-import           CLaSH.Util  ((***), curLoc, traceIf)--runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a-runIfl modName action = do-  hscEnv <- GHC.getSession-  let localEnv = TcRnTypes.IfLclEnv modName (text "runIfl")-                   UniqFM.emptyUFM UniqFM.emptyUFM-#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)-  let globalEnv = TcRnTypes.IfGblEnv (text "CLaSH.runIfl") Nothing-#else-  let globalEnv = TcRnTypes.IfGblEnv Nothing-#endif-  MonadUtils.liftIO $ TcRnMonad.initTcRnIf 'r' hscEnv globalEnv-                        localEnv action--loadDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL GHC.TyThing-loadDecl = TcIface.tcIfaceDecl False--loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface)-loadIface foundMod = do-  ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface") foundMod False-  case ifaceFailM of-    Maybes.Succeeded (modInfo,_) -> return (Just modInfo)-    Maybes.Failed msg -> let msg' = concat [ $(curLoc)-                                           , "Failed to load interface for module: "-                                           , showPpr unsafeGlobalDynFlags foundMod-                                           , "\nReason: "-                                           , showSDoc unsafeGlobalDynFlags msg-                                           ]-                         in traceIf True msg' (return Nothing)--loadExternalExprs ::-  GHC.GhcMonad m-  => HDL-  -> [CoreSyn.CoreExpr]-  -> [CoreSyn.CoreBndr]-  -> m ( [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)] -- Binders-       , [(CoreSyn.CoreBndr,Int)]              -- Class Ops-       , [CoreSyn.CoreBndr]                    -- Unlocatable-       , [FilePath]-       )-loadExternalExprs _   []           _       = return ([],[],[],[])-loadExternalExprs hdl (expr:exprs) visited = do-  let fvs = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars-              (\v -> Var.isId v &&-                     isNothing (Id.isDataConId_maybe v) &&-                     v `notElem` visited-              ) expr--  let (clsOps,fvs') = partition (isJust . Id.isClassOpId_maybe) fvs--  ((locatedExprs,unlocated),pFP) <--     ((partitionEithers *** concat) . unzip) <$> mapM (loadExprFromIface hdl) fvs'--  let visited' = concat [ map fst locatedExprs-                        , unlocated-                        , clsOps-                        , visited-                        ]--  (locatedExprs', clsOps', unlocated',pFP') <--    loadExternalExprs-      hdl-      (exprs ++ map snd locatedExprs)-      visited'--  let 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--  return ( locatedExprs ++ locatedExprs'-         , clsOps''     ++ clsOps'-         , unlocated    ++ unlocated'-         , pFP          ++ pFP'-         )--loadExprFromIface ::-  GHC.GhcMonad m-  => HDL-  -> CoreSyn.CoreBndr-  -> m (Either-          (CoreSyn.CoreBndr,CoreSyn.CoreExpr)-          CoreSyn.CoreBndr-       ,[FilePath]-       )-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,[])-        Just iface -> do-          let decls = map snd (GHC.mi_decls iface)-          let nameFun = GHC.getOccName $ Var.varName bndr-          let declM = filter ((== nameFun) . IfaceSyn.ifName) decls-          anns <- TcIface.tcIfaceAnnotations (GHC.mi_anns iface)-          let primFPs = loadPrimitiveAnnotations hdl anns-          case declM of-            [namedDecl] -> do-              tyThing <- loadDecl namedDecl-              return (loadExprFromTyThing bndr tyThing,primFPs)-            _ -> return (Right bndr,primFPs)-    Nothing -> return (Right bndr,[])--loadPrimitiveAnnotations-  :: HDL-  -> [Annotations.Annotation]-  -> [FilePath]-loadPrimitiveAnnotations hdl anns = mapMaybe toFP (concat prims)-  where-    annEnv       = Annotations.mkAnnEnv anns-    prims        = UniqFM.eltsUFM (Annotations.deserializeAnns deserializer annEnv)-    deserializer = Serialized.deserializeWithData :: ([Word8] -> Primitive)-    toFP (Primitive hdl' fp)-      | hdl == hdl'-      = Just fp-    toFP _ = Nothing--loadExprFromTyThing :: CoreSyn.CoreBndr-                    -> GHC.TyThing-                    -> Either-                         (CoreSyn.CoreBndr,CoreSyn.CoreExpr)  -- Located Binder-                         CoreSyn.CoreBndr                     -- unlocatable Var-loadExprFromTyThing bndr tyThing = case tyThing of-  GHC.AnId _id | Var.isId _id ->-    let _idInfo    = Var.idInfo _id-        unfolding  = IdInfo.unfoldingInfo _idInfo-        inlineInfo = IdInfo.inlinePragInfo _idInfo-    in case unfolding of-      (CoreSyn.CoreUnfolding {}) ->-        case (BasicTypes.inl_inline inlineInfo,BasicTypes.inl_act inlineInfo) of-          (BasicTypes.NoInline,BasicTypes.AlwaysActive) -> Right bndr-          (BasicTypes.NoInline,BasicTypes.NeverActive)  -> Right bndr-          (BasicTypes.NoInline,_) -> Left (bndr, CoreSyn.unfoldingTemplate unfolding)-          _ -> Left (bndr, CoreSyn.unfoldingTemplate unfolding)-      (CoreSyn.DFunUnfolding dfbndrs dc es) ->-        let dcApp  = MkCore.mkCoreConApps dc es-            dfExpr = MkCore.mkCoreLams dfbndrs dcApp-        in Left (bndr,dfExpr)-      CoreSyn.NoUnfolding-        | Demand.isBottomingSig $ IdInfo.strictnessInfo _idInfo-        -> Left (bndr, MkCore.mkRuntimeErrorApp MkCore.aBSENT_ERROR_ID-                                                (Var.varType _id)-                                                "no_unfolding"-                )-      _ -> Right bndr-  _ -> Right bndr
− src-ghc/CLaSH/GHC/LoadModules.hs 
@@ -1,411 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP                 #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE ViewPatterns        #-}--module CLaSH.GHC.LoadModules-  ( loadModules-  , ghcLibDir-  )-where--#ifndef TOOL_VERSION_ghc-#error TOOL_VERSION_ghc undefined-#endif---- External Modules-import           Data.Generics.Uniplate.DataOnly (transform)-import           Data.List                    (foldl', nub)-import           Data.Word                    (Word8)-import           CLaSH.Annotations.Primitive  (HDL)-import           CLaSH.Annotations.TopEntity  (TopEntity)-import           System.Exit                  (ExitCode (..))-import           System.IO                    (hGetLine)-import           System.IO.Error              (tryIOError)-import           System.Process               (runInteractiveCommand,-                                               waitForProcess)---- GHC API-import qualified Annotations-import qualified CoreSyn-import qualified Digraph-import           DynFlags                     (GeneralFlag (..))-import qualified DynFlags-import qualified GHC-import qualified HscMain-import qualified HscTypes-import qualified MonadUtils-import qualified Panic-import qualified Serialized-import qualified TidyPgm-import qualified TcRnMonad-import qualified TcRnTypes-import qualified UniqFM-import qualified Var-import qualified FamInst-import qualified FamInstEnv-import qualified Name-import qualified Module-import           Outputable                   ((<>),dot,ppr)-import qualified Outputable-import qualified OccName-import qualified GHC.LanguageExtensions       as LangExt---- Internal Modules-import           CLaSH.GHC.LoadInterfaceFiles-import           CLaSH.Util                   (curLoc,first)--ghcLibDir :: IO FilePath-ghcLibDir = do-  (libDirM,exitCode) <- getProcessOutput $ "ghc-" ++ TOOL_VERSION_ghc ++ " --print-libdir"-  case exitCode of-     ExitSuccess   -> case libDirM of-       Just libDir -> return libDir-       Nothing     -> Panic.pgmError noGHC-     ExitFailure i -> case i of-       127         -> Panic.pgmError noGHC-       i'          -> Panic.pgmError $ "Calling GHC failed with error code: " ++ show i'-  where-    noGHC = "CLaSH needs the GHC compiler it was built with, ghc-" ++ TOOL_VERSION_ghc ++-            ", but it was not found. Make sure its location is in your PATH variable."--getProcessOutput :: String -> IO (Maybe String, ExitCode)-getProcessOutput command =-     -- Create the process-  do (_, pOut, _, handle) <- runInteractiveCommand command-     -- Wait for the process to finish and store its exit code-     exitCode <- waitForProcess handle-     -- Get the standard output.-     output   <- either (const Nothing) Just <$> tryIOError (hGetLine pOut)-     -- return both the output and the exit code.-     return (output, exitCode)--loadModules-  :: HDL-  -> String-  -> Maybe (DynFlags.DynFlags)-  -> IO ( [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]   -- Binders-        , [(CoreSyn.CoreBndr,Int)]                 -- Class operations-        , [CoreSyn.CoreBndr]                       -- Unlocatable Expressions-        , FamInstEnv.FamInstEnvs-        , (CoreSyn.CoreBndr, Maybe TopEntity)      -- topEntity bndr + (maybe) TopEntity annotation-        , Maybe CoreSyn.CoreBndr                   -- testInput bndr-        , Maybe CoreSyn.CoreBndr                   -- expectedOutput bndr-        , [FilePath]-        )-loadModules hdl modName dflagsM = do-  libDir <- MonadUtils.liftIO ghcLibDir--  GHC.runGhc (Just libDir) $ do-    dflags <- case dflagsM of-                Just df -> return df-                Nothing -> do-                  df <- GHC.getSessionDynFlags-                  let dfEn = foldl DynFlags.xopt_set df-                                [ LangExt.TemplateHaskell-                                , LangExt.TemplateHaskellQuotes-                                , LangExt.DataKinds-                                , LangExt.TypeOperators-                                , LangExt.FlexibleContexts-                                , LangExt.ConstraintKinds-                                , LangExt.TypeFamilies-                                , LangExt.BinaryLiterals-                                , LangExt.ExplicitNamespaces-                                , LangExt.KindSignatures-                                , LangExt.DeriveLift-                                , LangExt.TypeApplications-                                , LangExt.ScopedTypeVariables-                                , LangExt.MagicHash-                                , LangExt.ExplicitForAll-                                ]-                  let dfDis = foldl DynFlags.xopt_unset dfEn-                                [ LangExt.ImplicitPrelude-                                , LangExt.MonomorphismRestriction-                                , LangExt.Strict-                                , LangExt.StrictData-                                ]-                  let ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"-                      ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"-                      ghcTyLitKNPlugin   = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"-                  let dfPlug = dfDis { DynFlags.pluginModNames = nub $-                                          ghcTyLitNormPlugin : ghcTyLitExtrPlugin :-                                          ghcTyLitKNPlugin : DynFlags.pluginModNames dfDis-                                     }-                  return dfPlug--    let dflags1 = dflags-#if __GLASGOW_HASKELL__ >= 711-                    { DynFlags.reductionDepth = 1000-#else-                    { DynFlags.ctxtStkDepth = 1000-#endif-                    , DynFlags.optLevel = 2-                    , DynFlags.ghcMode  = GHC.CompManager-                    , DynFlags.ghcLink  = GHC.LinkInMemory-                    , DynFlags.hscTarget = DynFlags.defaultObjectTarget-                                             (DynFlags.targetPlatform dflags)-                    }-    let dflags2 = wantedOptimizationFlags 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-    _ <- GHC.setSessionDynFlags dflags3-    target <- GHC.guessTarget modName Nothing-    GHC.setTargets [target]-    modGraph <- GHC.depanal [] False-    let modGraph' = map disableOptimizationsFlags modGraph-        modGraph2 = Digraph.flattenSCCs (GHC.topSortModuleGraph True modGraph' Nothing)-    tidiedMods <- mapM (\m -> do { pMod  <- parseModule m-                                 ; 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-                                 ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod-                                 ; (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-                                 ; return (CoreSyn.flattenBinds pgm,modFamInstEnv)-                                 }-                         ) modGraph2--    let (binders,modFamInstEnvs) = first concat $ unzip tidiedMods-        modFamInstEnvs'          = foldr UniqFM.plusUFM UniqFM.emptyUFM modFamInstEnvs--    (externalBndrs,clsOps,unlocatable,pFP) <--      loadExternalExprs hdl (map snd binders) (map fst binders)--    hscEnv <- GHC.getSession-    famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs--    let rootModule = GHC.ms_mod_name . last $ modGraph2-        rootBndrs = filter (maybe False-                                  ((== rootModule)-                                   . Module.moduleName)-                            . Name.nameModule_maybe-                            . Var.varName)-                           (map fst binders)--    topEntM <- findCLaSHAnnotations rootBndrs-    let varNameString = OccName.occNameString . Name.nameOccName . Var.varName-        topEntities     = filter ((== "topEntity") . varNameString) rootBndrs-        testInputs      = filter ((== "testInput") . varNameString) rootBndrs-        expectedOutputs = filter ((== "expectedOutput") . varNameString) rootBndrs-    topEntity <- case topEntities of-      [] -> case topEntM of-              Just (l,r) -> return (l,Just r)-              _ -> Panic.pgmError $ "No 'topEntity', nor function with a 'TopEntity' annotation found in root module: " ++-                                    (Outputable.showSDocUnsafe (ppr rootModule))-      [x] -> case topEntM of-              Just (l,r) | l == x    -> return (l,Just r)-                         | otherwise -> Panic.pgmError $ "'TopEntity' annotation applied to a function that is not named 'topEntity' while a 'topEntity' function is present: " ++-                                                         (Outputable.showSDocUnsafe (ppr rootModule <> dot <> ppr l))-              Nothing -> return (x,Nothing)-      _ -> Panic.pgmError $ $(curLoc) ++  "Multiple 'topEntities' found."-    testInput <- case testInputs of-      []  -> return Nothing-      [x] -> return (Just x)-      _  -> Panic.pgmError $ $(curLoc) ++ "Multiple 'testInput's found."-    expectedOutput <- case expectedOutputs of-      []  -> return Nothing-      [x] -> return (Just x)-      _  -> Panic.pgmError $ $(curLoc) ++ "Multiple 'testInput's found."--    return (binders ++ externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntity,testInput,expectedOutput,nub pFP)--findCLaSHAnnotations :: GHC.GhcMonad m-                     => [CoreSyn.CoreBndr]-                     -> m (Maybe (CoreSyn.CoreBndr,TopEntity))-findCLaSHAnnotations bndrs = do-  let deserializer = Serialized.deserializeWithData :: ([Word8] -> TopEntity)-      targets      = map (Annotations.NamedTarget . Var.varName) bndrs--  anns <- mapM (GHC.findGlobalAnns deserializer) targets-  let annBndrs = filter (not . null . snd) (zip bndrs anns)-  case annBndrs of-    []  -> return Nothing-    [(x,[y])] -> return (Just (x,y))-    [(x,_)] -> Panic.pgmError $ "Root module contains a function with multiple 'TopEntity' annotation: " ++ Outputable.showSDocUnsafe (ppr x)-    xs  -> Panic.pgmError $ "Root module contains multiple functions with a 'TopEntity' annotation: " ++ Outputable.showSDocUnsafe (ppr (map fst xs))--parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule-parseModule modSum = do-  (GHC.ParsedModule pmModSum pmParsedSource extraSrc anns) <--    GHC.parseModule modSum-  return (GHC.ParsedModule-            (disableOptimizationsFlags pmModSum)-            pmParsedSource extraSrc anns)--disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary-disableOptimizationsFlags ms@(GHC.ModSummary {..})-  = ms {GHC.ms_hspp_opts = dflags}-  where-    dflags = wantedOptimizationFlags (ms_hspp_opts-              { DynFlags.optLevel = 2-#if __GLASGOW_HASKELL__ >= 711-              , DynFlags.reductionDepth = 1000-#else-              , DynFlags.ctxtStkDepth = 1000-#endif-              })--wantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags-wantedOptimizationFlags df =-  foldl' DynFlags.xopt_unset-    (foldl' DynFlags.gopt_unset-        (foldl' DynFlags.gopt_set df wanted) unwanted) unwantedLang-  where-    wanted = [ Opt_CSE -- CSE-             , Opt_Specialise -- Specialise on types, specialise type-class-overloaded function defined in this module for the types-             , Opt_DoLambdaEtaExpansion -- transform nested series of lambdas into one with multiple arguments, helps us achieve only top-level lambdas-             , Opt_CaseMerge -- We want fewer case-statements-             , Opt_DictsCheap -- Makes dictionaries seem cheap to optimizer: hopefully inline-             , Opt_ExposeAllUnfoldings -- We need all the unfoldings we can get-             , Opt_ForceRecomp -- Force recompilation: never bad-             , Opt_EnableRewriteRules -- Reduce number of functions-             , Opt_SimplPreInlining -- Inlines simple functions, we only care about the major first-order structure-             , Opt_StaticArgumentTransformation -- Turn on the static argument transformation, which turns a recursive function into a non-recursive one with a local recursive loop.-             , Opt_FloatIn -- Moves let-bindings inwards, although it defeats the normal-form with a single top-level let-binding, it helps with other transformations-             , Opt_DictsStrict -- Hopefully helps remove class method selectors-             , Opt_DmdTxDictSel -- I think demand and strictness are related, strictness helps with dead-code, enable-             , Opt_Strictness -- Strictness analysis helps with dead-code analysis. However, see [NOTE: CPR breaks CLaSH]-             , Opt_SpecialiseAggressively -- Needed to compile Fixed point number functions quickly-             , Opt_CrossModuleSpecialise -- Needed to compile Fixed point number functions quickly-             ]--    unwanted = [ Opt_LiberateCase -- Perform unrolling of recursive RHS: avoid-               , Opt_SpecConstr -- Creates local-functions: avoid-               , Opt_IgnoreAsserts -- We don't care about assertions-               , Opt_DoEtaReduction -- We want eta-expansion-               , Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid-               , Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid-               , Opt_Vectorise -- Don't care-               , Opt_VectorisationAvoidance -- Don't care-               , Opt_RegsGraph -- Don't care-               , Opt_RegsGraph -- Don't care-               , Opt_PedanticBottoms -- Stops eta-expansion through case: avoid-               , Opt_LlvmTBAA -- Don't care-               , Opt_CmmSink -- Don't care-               , Opt_CmmElimCommonBlocks -- Don't care-               , Opt_OmitYields -- Don't care-               , Opt_IgnoreInterfacePragmas -- We need all the unfoldings we can get-               , Opt_OmitInterfacePragmas -- We need all the unfoldings we can get-               , Opt_IrrefutableTuples -- Introduce irrefutPatError: avoid-               , Opt_Loopification -- STG pass, don't care-               , Opt_CprAnal -- The worker/wrapper introduced by CPR breaks CLaSH, see [NOTE: CPR breaks CLaSH]-               , Opt_FullLaziness -- increases sharing, but seems to result in worse circuits (in both area and propagation delay)-               ]--    -- Coercions between Integer and CLaSH' numeric primitives cause CLaSH to-    -- fail. As strictness only affects simulation behaviour, removing them-    -- is perfectly safe.-    unwantedLang = [ LangExt.Strict-                   , LangExt.StrictData-                   ]---- [NOTE: CPR breaks CLaSH]--- We used to completely disable strictness analysis because it causes GHC to--- do the so-called "Constructed Product Result" (CPR) analysis, which in turn--- creates an annoying worker/wrapper which does the following:------   * Scrutinise a Signal, and pack the head and tail of the---     Signal in an unboxed tuple.---   * Scrutinise on the unboxed tuple, and recreate the Signal.------ This is problematic because the 'Signal' type is essentially treated as a "transparent"--- type by the CLaSH compiler, so observing its constructor leads to all kinds--- of problems.------ The current solution is to disable strictness analysis in "CLaSH.Signal.Internal"--- so that functions manipulating 'Signal' constructor do not get a strictness/--- demand/CPR annotation, which in turn ensures GHC doesn't create worker/wrappers--- for when these functions are called in user code.------ Ultimately we should stop treating Signal as a "transparent" type and deal--- handling of the Signal type, and the involved co-recursive functions,--- properly. At the moment, CLaSH cannot deal with this recursive type and the--- recursive functions involved, and hence we need to disable this useful transformation. After--- everything is done properly, we should enable it again.---- | Remove all strictness annotations:------ * Remove strictness annotations from data type declarations---   (only works for data types that are currently being compiled, i.e.,---    that are not part of a pre-compiled imported library)------ We need to remove strictness annotations because GHC will introduce casts--- between Integer and CLaSH' numeric primitives otherwise, where CLaSH will--- error when it sees such casts. The reason it does this is because--- Integer is a completely unconstrained integer type and is currently--- (erroneously) translated to a 64-bit integer in the HDL; this means that--- we could lose bits when the original numeric type had more bits than 64.------ Removing these strictness annotations is perfectly safe, as they only--- affect simulation behaviour.-removeStrictnessAnnotations ::-     GHC.ParsedModule-  -> GHC.ParsedModule-removeStrictnessAnnotations pm =-    pm {GHC.pm_parsed_source = fmap rmPS (GHC.pm_parsed_source pm)}-  where-    rmPS :: GHC.DataId name => GHC.HsModule name -> GHC.HsModule name-    rmPS hsm = hsm {GHC.hsmodDecls = (fmap . fmap) rmHSD (GHC.hsmodDecls hsm)}--    rmHSD :: GHC.DataId name => GHC.HsDecl name -> GHC.HsDecl name-    rmHSD (GHC.TyClD tyClDecl) = GHC.TyClD (rmTyClD tyClDecl)-    rmHSD hsd = hsd--    rmTyClD :: GHC.DataId name => GHC.TyClDecl name -> GHC.TyClDecl name-    rmTyClD dc@(GHC.DataDecl {}) = dc {GHC.tcdDataDefn = rmDataDefn (GHC.tcdDataDefn dc)}-    rmTyClD tyClD = tyClD--    rmDataDefn :: GHC.DataId name => GHC.HsDataDefn name -> GHC.HsDataDefn name-    rmDataDefn hdf = hdf {GHC.dd_cons = (fmap . fmap) rmCD (GHC.dd_cons hdf)}--    rmCD :: GHC.DataId name => GHC.ConDecl name -> GHC.ConDecl name-    rmCD gadt@(GHC.ConDeclGADT {}) = gadt {GHC.con_type = rmSigType (GHC.con_type gadt)}-    rmCD h98@(GHC.ConDeclH98 {})   = h98  {GHC.con_details = rmConDetails (GHC.con_details h98)}--    -- type LHsSigType name = HsImplicitBndrs name (LHsType name)-    rmSigType :: GHC.DataId name => GHC.LHsSigType name -> GHC.LHsSigType name-    rmSigType hsIB = hsIB {GHC.hsib_body = rmHsType (GHC.hsib_body hsIB)}--    -- type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name])-    rmConDetails :: GHC.DataId name => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name-    rmConDetails (GHC.PrefixCon args) = GHC.PrefixCon (fmap rmHsType args)-    rmConDetails (GHC.RecCon rec)     = GHC.RecCon ((fmap . fmap . fmap) rmConDeclF rec)-    rmConDetails (GHC.InfixCon l r)   = GHC.InfixCon (rmHsType l) (rmHsType r)--    rmHsType :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name)-    rmHsType = transform go-      where-        go (GHC.unLoc -> GHC.HsBangTy _ ty) = ty-        go ty = ty--    rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name-    rmConDeclF cdf = cdf {GHC.cd_fld_type = rmHsType (GHC.cd_fld_type cdf)}
− src-ghc/CLaSH/GHC/NetlistTypes.hs 
@@ -1,125 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.GHC.NetlistTypes-  (ghcTypeToHWType)-where--import Data.Coerce                      (coerce)-import Data.Functor.Identity            (Identity (..))-import Data.HashMap.Strict              (HashMap,(!))-import Control.Monad.Trans.Except       (ExceptT (..), mapExceptT, runExceptT)-import Unbound.Generics.LocallyNameless (name2String)--import CLaSH.Core.DataCon               (DataCon (..))-import CLaSH.Core.Pretty                (showDoc)-import CLaSH.Core.TyCon                 (TyCon (..), TyConName, tyConDataCons)-import CLaSH.Core.Type                  (Type (..), TypeView (..), tyView)-import CLaSH.Core.Util                  (tyNatSize)-import CLaSH.Netlist.Util               (coreTypeToHWType)-import CLaSH.Netlist.Types              (HWType(..))-import CLaSH.Util                       (curLoc)--ghcTypeToHWType :: Int-                -> Bool-                -> HashMap TyConName TyCon-                -> Type-                -> Maybe (Either String HWType)-ghcTypeToHWType iw floatSupport = go-  where-    go m ty@(tyView -> TyConApp tc args) = runExceptT $-      case name2String tc of-        "GHC.Int.Int8"                  -> return (Signed 8)-        "GHC.Int.Int16"                 -> return (Signed 16)-        "GHC.Int.Int32"                 -> return (Signed 32)-        "GHC.Int.Int64"                 ->-          if iw < 64-             then case tyConDataCons (m ! tc) of-                    [dc] -> case dcArgTys dc of-                      [tyView -> TyConApp nm _]-                        | name2String nm == "GHC.Prim.Int#"   ->-                            error $ unlines ["Int64 not supported in forced 32-bit mode on a 64-bit machine."-                                            ,"Run CLaSH with `-clash-intwidth=64`."-                                            ]-                        | name2String nm == "GHC.Prim.Int64#" ->-                            return (Signed 64)-                      _  -> error $ $(curLoc) ++ "Int64 DC has unexpected amount of arguments"-                    _    -> error $ $(curLoc) ++ "Int64 TC has unexpected amount of DCs"-             else return (Signed 64)-        "GHC.Word.Word8"                -> return (Unsigned 8)-        "GHC.Word.Word16"               -> return (Unsigned 16)-        "GHC.Word.Word32"               -> return (Unsigned 32)-        "GHC.Word.Word64"               ->-          if iw < 64-             then case tyConDataCons (m ! tc) of-                    [dc] -> case dcArgTys dc of-                      [tyView -> TyConApp nm _]-                        | name2String nm == "GHC.Prim.Word#"   ->-                            error $ unlines ["Word64 not supported in forced 32-bit mode on a 64-bit machine."-                                            ,"Run CLaSH with `-clash-intwidth=64`."-                                            ]-                        | name2String nm == "GHC.Prim.Word64#" ->-                            return (Unsigned 64)-                      _  -> error $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments"-                    _    -> error $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs"-             else return (Unsigned 64)-        "GHC.Integer.Type.Integer"      -> return (Signed iw)-        "GHC.Prim.Char#"                -> return (Unsigned 21)-        "GHC.Prim.Int#"                 -> return (Signed iw)-        "GHC.Prim.Word#"                -> return (Unsigned iw)-        "GHC.Prim.Int64#"               -> return (Signed 64)-        "GHC.Prim.Word64#"              -> return (Unsigned 64)-        "GHC.Prim.Float#" | floatSupport -> return (BitVector 32)-        "GHC.Prim.Double#" | floatSupport -> return (BitVector 64)-        "GHC.Prim.ByteArray#"           ->-          fail $ "Can't translate type: " ++ showDoc ty--        "GHC.Types.Bool"                -> return Bool-        "GHC.Types.Float" | floatSupport-> return (BitVector 32)-        "GHC.Types.Double" | floatSupport -> return (BitVector 64)-        "GHC.Prim.~#"                   -> return (Sum "GHC.Prim.~#" ["GHC.Types.Eq#"])--        "GHC.Prim.Any" -> return (BitVector 1)--        "CLaSH.Signal.Internal.Signal'" ->-          ExceptT $ return $ coreTypeToHWType go m (args !! 1)--        "CLaSH.Sized.Internal.BitVector.BitVector" ->-          (BitVector . fromInteger) <$> mapExceptT (Just . coerce) (tyNatSize m (head args))--        "CLaSH.Sized.Internal.Index.Index" ->-          Index <$> mapExceptT (Just . coerce) (tyNatSize m (head args))--        "CLaSH.Sized.Internal.Signed.Signed" ->-          (Signed . fromInteger) <$> mapExceptT (Just . coerce) (tyNatSize m (head args))--        "CLaSH.Sized.Internal.Unsigned.Unsigned" ->-          (Unsigned . fromInteger) <$> mapExceptT (Just . coerce) (tyNatSize m (head args))--        "CLaSH.Sized.Vector.Vec" -> do-          let [szTy,elTy] = args-          sz     <- mapExceptT (Just . coerce) (tyNatSize m szTy)-          elHWTy <- ExceptT $ return $ coreTypeToHWType go m elTy-          return $ Vector (fromInteger sz) elHWTy--        "CLaSH.Sized.RTree.RTree" -> do-          let [szTy,elTy] = args-          sz     <- mapExceptT (Just . coerce) (tyNatSize m szTy)-          elHWTy <- ExceptT $ return $ coreTypeToHWType go m elTy-          return $ RTree (fromInteger sz) elHWTy--        "String" -> return String-        "GHC.Types.[]" -> case tyView (head args) of-          (TyConApp (name2String -> "GHC.Types.Char") []) -> return String-          _ -> fail $ "Can't translate type: " ++ showDoc ty--        _ -> ExceptT Nothing--    go _ _ = Nothing
+ src-ghc/Clash/GHC/ClashFlags.hs view
@@ -0,0 +1,139 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente,+                     2016-2017, Myrtle Software Ltd+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP           #-}+{-# LANGUAGE TupleSections #-}++module Clash.GHC.ClashFlags+  ( parseClashFlags+  )+where++import CmdLineParser+import Panic+import SrcLoc++import Data.IORef+import Control.Monad+import Clash.Driver.Types+import Clash.Netlist.BlackBox.Types (HdlSyn (..))+import Text.Read (readMaybe)++parseClashFlags :: IORef ClashOpts -> [Located String]+                -> IO ([Located String]+#if MIN_VERSION_ghc(8,4,1)+                      ,[Warn])+#else+                      ,[Located String])+#endif+parseClashFlags r = parseClashFlagsFull (flagsClash r)++parseClashFlagsFull :: [Flag IO] -> [Located String]+                    -> IO ([Located String]+#if MIN_VERSION_ghc(8,4,1)+                          ,[Warn])+#else+                          ,[Located String])+#endif+parseClashFlagsFull flagsAvialable args = do+  (leftovers,errs,warns) <- processArgs flagsAvialable args++  unless (null errs) $ throwGhcExceptionIO $+    errorsToGhcException . map (("on the commandline", ) .+#if MIN_VERSION_ghc(8,4,1)+                               unLoc . errMsg)+#else+                               unLoc)+#endif+                         $ errs++  return (leftovers, warns)++flagsClash :: IORef ClashOpts -> [Flag IO]+flagsClash r = [+    defFlag "fclash-debug"                   $ SepArg (setDebugLevel r)+  , defFlag "fclash-hdldir"                  $ SepArg (setHdlDir r)+  , defFlag "fclash-hdlsyn"                  $ SepArg (setHdlSyn r)+  , defFlag "fclash-nocache"                 $ NoArg (liftEwM (setNoCache r))+  , defFlag "fclash-noclean"                 $ NoArg (liftEwM (setNoClean r))+  , defFlag "fclash-spec-limit"              $ IntSuffix (liftEwM . setSpecLimit r)+  , defFlag "fclash-inline-limit"            $ IntSuffix (liftEwM . setInlineLimit r)+  , defFlag "fclash-inline-function-limit"   $ IntSuffix (liftEwM . setInlineFunctionLimit r)+  , defFlag "fclash-inline-constant-limit"   $ IntSuffix (liftEwM . setInlineConstantLimit r)+  , defFlag "fclash-intwidth"                $ IntSuffix (setIntWidth r)+  , defFlag "fclash-error-extra"             $ NoArg (liftEwM (setErrorExtra r))+  , defFlag "fclash-float-support"           $ NoArg (liftEwM (setFloatSupport r))+  , defFlag "fclash-allow-zero-width"        $ NoArg (setAllowZeroWidth r)+  ]++setInlineLimit :: IORef ClashOpts+               -> Int+               -> IO ()+setInlineLimit r n = modifyIORef r (\c -> c {opt_inlineLimit = n})++setInlineFunctionLimit+  :: IORef ClashOpts+  -> Int+  -> IO ()+setInlineFunctionLimit r n = modifyIORef r (\c -> c {opt_inlineFunctionLimit = toEnum n})++setInlineConstantLimit+  :: IORef ClashOpts+  -> Int+  -> IO ()+setInlineConstantLimit r n = modifyIORef r (\c -> c {opt_inlineConstantLimit = toEnum n})++setSpecLimit :: IORef ClashOpts+             -> Int+             -> IO ()+setSpecLimit r n = modifyIORef r (\c -> c {opt_specLimit = n})++setDebugLevel :: IORef ClashOpts+              -> String+              -> EwM IO ()+setDebugLevel r s = case readMaybe s of+  Just dbgLvl -> liftEwM $ modifyIORef r (\c -> c {opt_dbgLevel = dbgLvl})+  Nothing     -> addWarn (s ++ " is an invalid debug level")++setNoCache :: IORef ClashOpts -> IO ()+setNoCache r = modifyIORef r (\c -> c {opt_cachehdl = False})++setNoClean :: IORef ClashOpts -> IO ()+setNoClean r = modifyIORef r (\c -> c {opt_cleanhdl = False})++setIntWidth :: IORef ClashOpts+            -> Int+            -> EwM IO ()+setIntWidth r n =+  if n == 32 || n == 64+     then liftEwM $ modifyIORef r (\c -> c {opt_intWidth = n})+     else addWarn (show n ++ " is an invalid Int/Word/Integer bit-width. Allowed widths: 32, 64.")++setHdlDir :: IORef ClashOpts+          -> String+          -> EwM IO ()+setHdlDir r s = liftEwM $ modifyIORef r (\c -> c {opt_hdlDir = Just s})++setHdlSyn :: IORef ClashOpts+          -> String+          -> EwM IO ()+setHdlSyn r s = case readMaybe s of+  Just hdlSyn -> liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = hdlSyn})+  Nothing     -> if s == "Xilinx"+                    then liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = Vivado})+                    else addWarn (s ++ " is an unknown hdl synthesis tool")++setErrorExtra :: IORef ClashOpts -> IO ()+setErrorExtra r = modifyIORef r (\c -> c {opt_errorExtra = True})++setFloatSupport :: IORef ClashOpts -> IO ()+setFloatSupport r = modifyIORef r (\c -> c {opt_floatSupport = True})++setAllowZeroWidth :: IORef ClashOpts -> EwM IO ()+setAllowZeroWidth r = do+  addWarn ("-fclash-allow-zero-width is deprecated and will be removed in Clash 1.0")+  liftEwM (modifyIORef r (\c -> c {opt_allowZero = True}))
+ src-ghc/Clash/GHC/Evaluator.hs view
@@ -0,0 +1,3528 @@+{-|+  Copyright   :  (C) 2013-2016, University of Twente,+                     2016-2017, Myrtle Software Ltd,+                     2017     , QBayLogic, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE UnboxedTuples     #-}++module Clash.GHC.Evaluator where++import           Control.Concurrent.Supply  (Supply,freshId)+import           Control.Monad              (ap)+import           Control.Monad.Trans.Except (runExcept)+import           Data.Bits+import           Data.Char           (chr,ord)+import qualified Data.Either         as Either+import qualified Data.HashMap.Strict as HashMap+import           Data.Maybe+  (fromMaybe, mapMaybe)+import qualified Data.List           as List+import           Data.Proxy          (Proxy)+import           Data.Reflection     (reifyNat)+import           Data.Text           (Text)+import           GHC.Float+import           GHC.Int+import           GHC.Integer         (decodeDoubleInteger,encodeDoubleInteger)+import           GHC.Prim+import           GHC.Real            (Ratio (..))+import           GHC.TypeLits        (KnownNat)+import           GHC.Word+import qualified Unbound.Generics.LocallyNameless.Name as U+import           Unbound.Generics.LocallyNameless+  (Fresh (..), bind, embed, rebind, runFreshM, makeName)++import           BasicTypes          (Boxity (..))+import           Name                (getSrcSpan, nameOccName, occNameString)+import           PrelNames+  (typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey)+import           SrcLoc              (wiredInSrcSpan)+import qualified TyCon+import           TysWiredIn          (tupleTyCon)+import           Unique              (getKey)++import           Clash.Class.BitPack (pack,unpack)+import           Clash.Core.DataCon  (DataCon (..), dataConInstArgTys)+import           Clash.Core.Evaluator+  (Heap (..), PrimEvaluator, Value (..), valToTerm, whnf)+import           Clash.Core.Literal  (Literal (..))+import           Clash.Core.Name+  (Name (..), NameSort (..), name2String, string2SystemName)+import           Clash.Core.Term     (Pat (..), Term (..))+import           Clash.Core.Type+  (Type (..), ConstTy (..), LitTy (..), TypeView (..), applyTy, mkFunTy, mkTyConApp,+   splitFunForallTy, tyView)+import           Clash.Core.TyCon+  (TyCon, TyConMap, TyConName, TyConOccName, tyConDataCons)+import           Clash.Core.TysPrim+import           Clash.Core.Util     (mkApps,mkRTree,mkVec,tyNatSize)+import           Clash.Core.Var      (Var (..))+import           Clash.GHC.GHC2Core  (modNameM)+import           Clash.Rewrite.Util  (mkSelectorCase)+import           Clash.Util+  (MonadUnique (..), clogBase, flogBase, curLoc)++import Clash.Promoted.Nat.Unsafe (unsafeSNat)+import qualified Clash.Sized.Internal.BitVector as BitVector+import qualified Clash.Sized.Internal.Signed    as Signed+import qualified Clash.Sized.Internal.Unsigned  as Unsigned+import Clash.Sized.Internal.BitVector(BitVector(..), Bit)+import Clash.Sized.Internal.Signed   (Signed   (..))+import Clash.Sized.Internal.Unsigned (Unsigned (..))++newtype PrimEvalMonad a = PEM { runPEM :: Supply -> (a,Supply) }++instance Functor PrimEvalMonad where+  fmap f m = PEM (\s -> case runPEM m s of (a,s') -> (f a, s'))++instance Applicative PrimEvalMonad where+  pure  = return+  (<*>) = ap++instance Monad PrimEvalMonad where+  return a = PEM (\s -> (a,s))+  m >>= k  = PEM (\s -> case runPEM m s of (a,s') -> runPEM (k a) s')++instance Fresh PrimEvalMonad where+  fresh (U.Fn nm _)  =+    PEM (\s -> case freshId s of+                 (!i,!s') ->  let !i' = toInteger i+                              in  (U.Fn nm i',s'))+  fresh nm@(U.Bn {}) = PEM (\s -> (nm,s))++instance MonadUnique PrimEvalMonad where+  getUniqueM = PEM (\s -> case freshId s of (!i,!s') -> (i,s'))++reduceConstant :: PrimEvaluator+reduceConstant isSubj gbl tcm h k nm ty tys args = case nm of+-----------------+-- GHC.Prim.Char#+-----------------+  "GHC.Prim.gtChar#" | Just (i,j) <- charLiterals args+    -> reduce (boolToIntLiteral (i > j))+  "GHC.Prim.geChar#" | Just (i,j) <- charLiterals args+    -> reduce (boolToIntLiteral (i >= j))+  "GHC.Prim.eqChar#" | Just (i,j) <- charLiterals args+    -> reduce (boolToIntLiteral (i == j))+  "GHC.Prim.neChar#" | Just (i,j) <- charLiterals args+    -> reduce (boolToIntLiteral (i /= j))+  "GHC.Prim.ltChar#" | Just (i,j) <- charLiterals args+    -> reduce (boolToIntLiteral (i < j))+  "GHC.Prim.leChar#" | Just (i,j) <- charLiterals args+    -> reduce (boolToIntLiteral (i <= j))+  "GHC.Prim.ord#" | [i] <- charLiterals' args+    -> reduce (integerToIntLiteral (toInteger $ ord i))++----------------+-- GHC.Prim.Int#+----------------+  "GHC.Prim.+#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i+j))+  "GHC.Prim.-#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i-j))+  "GHC.Prim.*#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i*j))++  "GHC.Prim.mulIntMayOflo#" | Just (i,j) <- intLiterals  args+    -> let !(I# a)  = fromInteger i+           !(I# b)  = fromInteger j+           c :: Int#+           c = mulIntMayOflo# a b+       in  reduce (integerToIntLiteral (toInteger $ I# c))++  "GHC.Prim.quotInt#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i `quot` j))+  "GHC.Prim.remInt#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i `rem` j))+  "GHC.Prim.quotRemInt#" | Just (i,j) <- intLiterals args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           (q,r)   = quotRem i j+           ret     = mkApps (Data tupDc) (map Right tyArgs +++                    [Left (integerToIntLiteral q), Left (integerToIntLiteral r)])+       in  reduce ret++  "GHC.Prim.andI#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i .&. j))+  "GHC.Prim.orI#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i .|. j))+  "GHC.Prim.xorI#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i `xor` j))+  "GHC.Prim.notI#" | [i] <- intLiterals' args+    -> reduce (integerToIntLiteral (complement i))++  "GHC.Prim.negateInt#"+    | [Lit (IntLiteral i)] <- args+    -> reduce (integerToIntLiteral (negate i))++  "GHC.Prim.addIntC#" | Just (i,j) <- intLiterals args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(I# a)  = fromInteger i+           !(I# b)  = fromInteger j+           !(# d, c #) = addIntC# a b+       in  reduce $+           mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . IntLiteral . toInteger $ I# d)+                   , Left (Literal . IntLiteral . toInteger $ I# c)])+  "GHC.Prim.subIntC#" | Just (i,j) <- intLiterals args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(I# a)  = fromInteger i+           !(I# b)  = fromInteger j+           !(# d, c #) = subIntC# a b+       in  reduce $+           mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . IntLiteral . toInteger $ I# d)+                   , Left (Literal . IntLiteral . toInteger $ I# c)])++  "GHC.Prim.>#" | Just (i,j) <- intLiterals args+    -> reduce (boolToIntLiteral (i > j))+  "GHC.Prim.>=#" | Just (i,j) <- intLiterals args+    -> reduce (boolToIntLiteral (i >= j))+  "GHC.Prim.==#" | Just (i,j) <- intLiterals args+    -> reduce (boolToIntLiteral (i == j))+  "GHC.Prim./=#" | Just (i,j) <- intLiterals args+    -> reduce (boolToIntLiteral (i /= j))+  "GHC.Prim.<#" | Just (i,j) <- intLiterals args+    -> reduce (boolToIntLiteral (i < j))+  "GHC.Prim.<=#" | Just (i,j) <- intLiterals args+    -> reduce (boolToIntLiteral (i <= j))++  "GHC.Prim.chr#" | [i] <- intLiterals' args+    -> reduce (charToCharLiteral (chr $ fromInteger i))++  "GHC.Prim.int2Word#"+    | [Lit (IntLiteral i)] <- args+    -> reduce . Literal . WordLiteral . toInteger $ (fromInteger :: Integer -> Word) i -- for overflow behaviour++  "GHC.Prim.int2Float#"+    | [Lit (IntLiteral i)] <- args+    -> reduce . Literal . FloatLiteral  . toRational $ (fromInteger i :: Float)+  "GHC.Prim.int2Double#"+    | [Lit (IntLiteral i)] <- args+    -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)++  "GHC.Prim.word2Float#"+    | [Lit (WordLiteral i)] <- args+    -> reduce . Literal . FloatLiteral  . toRational $ (fromInteger i :: Float)+  "GHC.Prim.word2Double#"+    | [Lit (WordLiteral i)] <- args+    -> reduce . Literal . DoubleLiteral . toRational $ (fromInteger i :: Double)++  "GHC.Prim.uncheckedIShiftL#"+    | [ Lit (IntLiteral i)+      , Lit (IntLiteral s)+      ] <- args+    -> reduce (integerToIntLiteral (i `shiftL` fromInteger s))+  "GHC.Prim.uncheckedIShiftRA#"+    | [ Lit (IntLiteral i)+      , Lit (IntLiteral s)+      ] <- args+    -> reduce (integerToIntLiteral (i `shiftR` fromInteger s))+  "GHC.Prim.uncheckedIShiftRL#" | Just (i,j) <- intLiterals args+    -> let !(I# a)  = fromInteger i+           !(I# b)  = fromInteger j+           c :: Int#+           c = uncheckedIShiftRL# a b+       in  reduce (integerToIntLiteral (toInteger $ I# c))++-----------------+-- GHC.Prim.Word#+-----------------+  "GHC.Prim.plusWord#" | Just (i,j) <- wordLiterals args+    -> reduce (integerToWordLiteral (i+j))++  "GHC.Prim.subWordC#" | Just (i,j) <- wordLiterals args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(W# a)  = fromInteger i+           !(W# b)  = fromInteger j+           !(# d, c #) = subWordC# a b+       in  reduce $+           mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . WordLiteral . toInteger $ W# d)+                   , Left (Literal . IntLiteral . toInteger $ I# c)])++  "GHC.Prim.plusWord2#" | Just (i,j) <- wordLiterals args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(W# a)  = fromInteger i+           !(W# b)  = fromInteger j+           !(# h', l #) = plusWord2# a b+       in  reduce $+           mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . WordLiteral . toInteger $ W# h')+                   , Left (Literal . WordLiteral . toInteger $ W# l)])++  "GHC.Prim.minusWord#" | Just (i,j) <- wordLiterals args+    -> reduce (integerToWordLiteral (i-j))+  "GHC.Prim.timesWord#" | Just (i,j) <- wordLiterals args+    -> reduce (integerToWordLiteral (i*j))++  "GHC.Prim.timesWord2#" | Just (i,j) <- wordLiterals args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(W# a)  = fromInteger i+           !(W# b)  = fromInteger j+           !(# h', l #) = timesWord2# a b+       in  reduce $+           mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . WordLiteral . toInteger $ W# h')+                   , Left (Literal . WordLiteral . toInteger $ W# l)])++  "GHC.Prim.quotWord#" | Just (i,j) <- wordLiterals args+    -> reduce (integerToWordLiteral (i `quot` j))+  "GHC.Prim.remWord#" | Just (i,j) <- wordLiterals args+    -> reduce (integerToWordLiteral (i `rem` j))+  "GHC.Prim.quotRemWord#" | Just (i,j) <- wordLiterals args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           (q,r)   = quotRem i j+           ret     = mkApps (Data tupDc) (map Right tyArgs +++                    [Left (integerToWordLiteral q), Left (integerToWordLiteral r)])+       in  reduce ret+  "GHC.Prim.quotRemWord2#" | [i,j,k'] <- wordLiterals' args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(W# a)  = fromInteger i+           !(W# b)  = fromInteger j+           !(W# c)  = fromInteger k'+           !(# x, y #) = quotRemWord2# a b c+       in  reduce $+           mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . WordLiteral . toInteger $ W# x)+                   , Left (Literal . WordLiteral . toInteger $ W# y)])++  "GHC.Prim.and#" | Just (i,j) <- wordLiterals args+    -> reduce (integerToWordLiteral (i .&. j))+  "GHC.Prim.or#" | Just (i,j) <- wordLiterals args+    -> reduce (integerToWordLiteral (i .|. j))+  "GHC.Prim.xor#" | Just (i,j) <- wordLiterals args+    -> reduce (integerToWordLiteral (i `xor` j))+  "GHC.Prim.not#" | [i] <- wordLiterals' args+    -> reduce (integerToWordLiteral (complement i))++  "GHC.Prim.uncheckedShiftL#"+    | [ Lit (WordLiteral w)+      , Lit (IntLiteral  i)+      ] <- args+    -> reduce (Literal (WordLiteral (w `shiftL` fromInteger i)))+  "GHC.Prim.uncheckedShiftRL#"+    | [ Lit (WordLiteral w)+      , Lit (IntLiteral  i)+      ] <- args+    -> reduce (Literal (WordLiteral (w `shiftR` fromInteger i)))++  "GHC.Prim.word2Int#"+    | [Lit (WordLiteral i)] <- args+    -> reduce . Literal . IntLiteral . toInteger $ (fromInteger :: Integer -> Int) i -- for overflow behaviour++  "GHC.Prim.gtWord#" | Just (i,j) <- wordLiterals args+    -> reduce (boolToIntLiteral (i > j))+  "GHC.Prim.geWord#" | Just (i,j) <- wordLiterals args+    -> reduce (boolToIntLiteral (i >= j))+  "GHC.Prim.eqWord#" | Just (i,j) <- wordLiterals args+    -> reduce (boolToIntLiteral (i == j))+  "GHC.Prim.neWord#" | Just (i,j) <- wordLiterals args+    -> reduce (boolToIntLiteral (i /= j))+  "GHC.Prim.ltWord#" | Just (i,j) <- wordLiterals args+    -> reduce (boolToIntLiteral (i < j))+  "GHC.Prim.leWord#" | Just (i,j) <- wordLiterals args+    -> reduce (boolToIntLiteral (i <= j))++  "GHC.Prim.popCnt8#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word8) $ i+  "GHC.Prim.popCnt16#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word16) $ i+  "GHC.Prim.popCnt32#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word32) $ i+  "GHC.Prim.popCnt64#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word64) $ i+  "GHC.Prim.popCnt#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . popCount . (fromInteger :: Integer -> Word) $ i++  "GHC.Prim.clz8#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word8) $ i+  "GHC.Prim.clz16#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word16) $ i+  "GHC.Prim.clz32#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word32) $ i+  "GHC.Prim.clz64#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word64) $ i+  "GHC.Prim.clz#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countLeadingZeros . (fromInteger :: Integer -> Word) $ i++  "GHC.Prim.ctz8#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 8 - 1)+  "GHC.Prim.ctz16#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 16 - 1)+  "GHC.Prim.ctz32#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i .&. (bit 32 - 1)+  "GHC.Prim.ctz64#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word64) $ i .&. (bit 64 - 1)+  "GHC.Prim.ctz#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . countTrailingZeros . (fromInteger :: Integer -> Word) $ i++  "GHC.Prim.byteSwap16#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . byteSwap16 . (fromInteger :: Integer -> Word16) $ i+  "GHC.Prim.byteSwap32#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . byteSwap32 . (fromInteger :: Integer -> Word32) $ i+  "GHC.Prim.byteSwap64#" | [i] <- wordLiterals' args+    -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i+  "GHC.Prim.byteSwap#" | [i] <- wordLiterals' args -- assume 64bits+    -> reduce . integerToWordLiteral . toInteger . byteSwap64 . (fromInteger :: Integer -> Word64) $ i++------------+-- Narrowing+------------+  "GHC.Prim.narrow8Int#" | [i] <- intLiterals' args+    -> let !(I# a)  = fromInteger i+           b = narrow8Int# a+       in  reduce . Literal . IntLiteral . toInteger $ I# b+  "GHC.Prim.narrow16Int#" | [i] <- intLiterals' args+    -> let !(I# a)  = fromInteger i+           b = narrow16Int# a+       in  reduce . Literal . IntLiteral . toInteger $ I# b+  "GHC.Prim.narrow32Int#" | [i] <- intLiterals' args+    -> let !(I# a)  = fromInteger i+           b = narrow32Int# a+       in  reduce . Literal . IntLiteral . toInteger $ I# b+  "GHC.Prim.narrow8Word#" | [i] <- wordLiterals' args+    -> let !(W# a)  = fromInteger i+           b = narrow8Word# a+       in  reduce . Literal . WordLiteral . toInteger $ W# b+  "GHC.Prim.narrow16Word#" | [i] <- wordLiterals' args+    -> let !(W# a)  = fromInteger i+           b = narrow16Word# a+       in  reduce . Literal . WordLiteral . toInteger $ W# b+  "GHC.Prim.narrow32Word#" | [i] <- wordLiterals' args+    -> let !(W# a)  = fromInteger i+           b = narrow32Word# a+       in  reduce . Literal . WordLiteral . toInteger $ W# b++----------+-- Double#+----------+  "GHC.Prim.>##"  | Just r <- liftDDI (>##)  args+    -> reduce r+  "GHC.Prim.>=##" | Just r <- liftDDI (>=##) args+    -> reduce r+  "GHC.Prim.==##" | Just r <- liftDDI (==##) args+    -> reduce r+  "GHC.Prim./=##" | Just r <- liftDDI (/=##) args+    -> reduce r+  "GHC.Prim.<##"  | Just r <- liftDDI (<##)  args+    -> reduce r+  "GHC.Prim.<=##" | Just r <- liftDDI (<=##) args+    -> reduce r+  "GHC.Prim.+##"  | Just r <- liftDDD (+##)  args+    -> reduce r+  "GHC.Prim.-##"  | Just r <- liftDDD (-##)  args+    -> reduce r+  "GHC.Prim.*##"  | Just r <- liftDDD (*##)  args+    -> reduce r+  "GHC.Prim./##"  | Just r <- liftDDD (/##)  args+    -> reduce r++  "GHC.Prim.negateDouble#" | Just r <- liftDD negateDouble# args+    -> reduce r+  "GHC.Prim.fabsDouble#" | Just r <- liftDD fabsDouble# args+    -> reduce r++  "GHC.Prim.double2Int#" | [i] <- doubleLiterals' args+    -> let !(D# a) = fromRational i+           r = double2Int# a+       in  reduce . Literal . IntLiteral . toInteger $ I# r+  "GHC.Prim.double2Float#"+    | [Lit (DoubleLiteral d)] <- args+    -> reduce (Literal (FloatLiteral (toRational (fromRational d :: Float))))+++  "GHC.Prim.expDouble#" | Just r <- liftDD expDouble# args+    -> reduce r+  "GHC.Prim.logDouble#" | Just r <- liftDD logDouble# args+    -> reduce r+  "GHC.Prim.sqrtDouble#" | Just r <- liftDD sqrtDouble# args+    -> reduce r+  "GHC.Prim.sinDouble#" | Just r <- liftDD sinDouble# args+    -> reduce r+  "GHC.Prim.cosDouble#" | Just r <- liftDD cosDouble# args+    -> reduce r+  "GHC.Prim.tanDouble#" | Just r <- liftDD tanDouble# args+    -> reduce r+  "GHC.Prim.asinDouble#" | Just r <- liftDD asinDouble# args+    -> reduce r+  "GHC.Prim.acosDouble#" | Just r <- liftDD acosDouble# args+    -> reduce r+  "GHC.Prim.atanDouble#" | Just r <- liftDD atanDouble# args+    -> reduce r+  "GHC.Prim.sinhDouble#" | Just r <- liftDD sinhDouble# args+    -> reduce r+  "GHC.Prim.coshDouble#" | Just r <- liftDD coshDouble# args+    -> reduce r+  "GHC.Prim.tanhDouble#" | Just r <- liftDD tanhDouble# args+    -> reduce r+  "GHC.Prim.**##" | Just r <- liftDDD (**##) args+    -> reduce r+-- decodeDouble_2Int# :: Double# -> (#Int#, Word#, Word#, Int##)+  "GHC.Prim.decodeDouble_2Int#" | [i] <- doubleLiterals' args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(D# a) = fromRational i+           !(# p, q, r, s #) = decodeDouble_2Int# a+       in reduce $+          mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . IntLiteral  . toInteger $ I# p)+                   , Left (Literal . WordLiteral . toInteger $ W# q)+                   , Left (Literal . WordLiteral . toInteger $ W# r)+                   , Left (Literal . IntLiteral  . toInteger $ I# s)])+-- decodeDouble_Int64# :: Double# -> (#Int#, Int##)+  "GHC.Prim.decodeDouble_Int64#" | [i] <- doubleLiterals' args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(D# a) = fromRational i+           !(# p, q #) = decodeDouble_Int64# a+       in reduce $+          mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . IntLiteral  . toInteger $ I# p)+                   , Left (Literal . IntLiteral  . toInteger $ I# q)])++--------+-- Float+--------+  "GHC.Prim.gtFloat#"  | Just r <- liftFFI gtFloat# args+    -> reduce r+  "GHC.Prim.geFloat#"  | Just r <- liftFFI geFloat# args+    -> reduce r+  "GHC.Prim.eqFloat#"  | Just r <- liftFFI eqFloat# args+    -> reduce r+  "GHC.Prim.neFloat#"  | Just r <- liftFFI neFloat# args+    -> reduce r+  "GHC.Prim.ltFloat#"  | Just r <- liftFFI ltFloat# args+    -> reduce r+  "GHC.Prim.leFloat#"  | Just r <- liftFFI leFloat# args+    -> reduce r++  "GHC.Prim.plusFloat#"  | Just r <- liftFFF plusFloat# args+    -> reduce r+  "GHC.Prim.minusFloat#"  | Just r <- liftFFF minusFloat# args+    -> reduce r+  "GHC.Prim.timesFloat#"  | Just r <- liftFFF timesFloat# args+    -> reduce r+  "GHC.Prim.divideFloat#"  | Just r <- liftFFF divideFloat# args+    -> reduce r++  "GHC.Prim.negateFloat#"  | Just r <- liftFF negateFloat# args+    -> reduce r+  "GHC.Prim.fabsFloat#"  | Just r <- liftFF fabsFloat# args+    -> reduce r++  "GHC.Prim.float2Int#" | [i] <- floatLiterals' args+    -> let !(F# a) = fromRational i+           r = float2Int# a+       in  reduce . Literal . IntLiteral . toInteger $ I# r++  "GHC.Prim.expFloat#"  | Just r <- liftFF expFloat# args+    -> reduce r+  "GHC.Prim.logFloat#"  | Just r <- liftFF logFloat# args+    -> reduce r+  "GHC.Prim.sqrtFloat#"  | Just r <- liftFF sqrtFloat# args+    -> reduce r+  "GHC.Prim.sinFloat#"  | Just r <- liftFF sinFloat# args+    -> reduce r+  "GHC.Prim.cosFloat#"  | Just r <- liftFF cosFloat# args+    -> reduce r+  "GHC.Prim.tanFloat#"  | Just r <- liftFF tanFloat# args+    -> reduce r+  "GHC.Prim.asinFloat#"  | Just r <- liftFF asinFloat# args+    -> reduce r+  "GHC.Prim.acosFloat#"  | Just r <- liftFF acosFloat# args+    -> reduce r+  "GHC.Prim.atanFloat#"  | Just r <- liftFF atanFloat# args+    -> reduce r+  "GHC.Prim.sinhFloat#"  | Just r <- liftFF sinhFloat# args+    -> reduce r+  "GHC.Prim.coshFloat#"  | Just r <- liftFF coshFloat# args+    -> reduce r+  "GHC.Prim.tanhFloat#"  | Just r <- liftFF tanhFloat# args+    -> reduce r+  "GHC.Prim.powerFloat#"  | Just r <- liftFFF powerFloat# args+    -> reduce r++  "GHC.Prim.float2Double#" | [i] <- floatLiterals' args+    -> let !(F# a) = fromRational i+           r = float2Double# a+       in  reduce . Literal . DoubleLiteral . toRational $ D# r++-- decodeFloat_Int# :: Float# -> (#Int#, Int##)+  "GHC.Prim.decodeFloat_Int#" | [i] <- floatLiterals' args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(F# a) = fromRational i+           !(# p, q #) = decodeFloat_Int# a+       in reduce $+          mkApps (Data tupDc) (map Right tyArgs +++                   [ Left (Literal . IntLiteral  . toInteger $ I# p)+                   , Left (Literal . IntLiteral  . toInteger $ I# q)])+++  "GHC.Prim.tagToEnum#"+    | [ConstTy (TyCon tcN)] <- tys+    , [Lit (IntLiteral i)]  <- args+    -> let dc = do { tc <- HashMap.lookup (nameOcc tcN) tcm+                   ; let dcs = tyConDataCons tc+                   ; List.find ((== (i+1)) . toInteger . dcTag) dcs+                   }+       in ((h,k,) . Data) <$> dc+++  "GHC.Classes.geInt" | Just (i,j) <- intCLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >= j))++  "GHC.Classes.&&"+    | [DC lCon _+      ,DC rCon _] <- args+    -> reduce $ boolToBoolLiteral tcm ty+         ((name2String (dcName lCon) == "GHC.Types.True") &&+          (name2String (dcName rCon) == "GHC.Types.True"))++  "GHC.Classes.||"+    | [DC lCon _+      ,DC rCon _] <- args+    -> reduce $ boolToBoolLiteral tcm ty+         ((name2String (dcName lCon) == "GHC.Types.True") ||+          (name2String (dcName rCon) == "GHC.Types.True"))++  "GHC.Classes.divInt#" | Just (i,j) <- intLiterals args+    -> reduce (integerToIntLiteral (i `div` j))++  "GHC.Classes.not"+    | [DC bCon _] <- args+    -> reduce (boolToBoolLiteral tcm ty (name2String (dcName bCon) == "GHC.Types.False"))++  "GHC.Integer.Logarithms.integerLogBase#"+    | Just (a,b) <- integerLiterals args+    , Just c <- flogBase a b+    -> (reduce . Literal . IntLiteral . toInteger) c++  "GHC.Integer.Type.smallInteger"+    | [Lit (IntLiteral i)] <- args+    -> reduce (Literal (IntegerLiteral i))++  "GHC.Integer.Type.integerToInt"+    | [Lit (IntegerLiteral i)] <- args+    -> reduce (integerToIntLiteral i)++  "GHC.Integer.Type.decodeDoubleInteger" -- :: Double# -> (#Integer, Int##)+    | [Lit (DoubleLiteral i)] <- args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           !(D# a)  = fromRational i+           !(# b, c #) = decodeDoubleInteger a+    in reduce $+       mkApps (Data tupDc) (map Right tyArgs +++                [ Left (integerToIntegerLiteral b)+                , Left (integerToIntLiteral . toInteger $ I# c)])++  "GHC.Integer.Type.encodeDoubleInteger" -- :: Integer -> Int# -> Double#+    | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+    -> let !(I# k') = fromInteger j+           r = encodeDoubleInteger i k'+    in  reduce . Literal . DoubleLiteral . toRational $ D# r++  "GHC.Integer.Type.quotRemInteger" -- :: Integer -> Integer -> (#Integer, Integer#)+    | [Lit (IntegerLiteral i), Lit (IntegerLiteral j)] <- args+    -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           (q,r) = quotRem i j+    in reduce $+         mkApps (Data tupDc) (map Right tyArgs +++                [ Left (integerToIntegerLiteral q)+                , Left (integerToIntegerLiteral r)])++  "GHC.Integer.Type.plusInteger" | Just (i,j) <- integerLiterals args+    -> reduce (integerToIntegerLiteral (i+j))++  "GHC.Integer.Type.minusInteger" | Just (i,j) <- integerLiterals args+    -> reduce (integerToIntegerLiteral (i-j))++  "GHC.Integer.Type.timesInteger" | Just (i,j) <- integerLiterals args+    -> reduce (integerToIntegerLiteral (i*j))++  "GHC.Integer.Type.negateInteger"+    | [Lit (IntegerLiteral i)] <- args+    -> reduce (integerToIntegerLiteral (negate i))++  "GHC.Integer.Type.divInteger" | Just (i,j) <- integerLiterals args+    -> reduce (integerToIntegerLiteral (i `div` j))++  "GHC.Integer.Type.modInteger" | Just (i,j) <- integerLiterals args+    -> reduce (integerToIntegerLiteral (i `mod` j))++  "GHC.Integer.Type.quotInteger" | Just (i,j) <- integerLiterals args+    -> reduce (integerToIntegerLiteral (i `quot` j))++  "GHC.Integer.Type.remInteger" | Just (i,j) <- integerLiterals args+    -> reduce (integerToIntegerLiteral (i `rem` j))++  "GHC.Integer.Type.divModInteger" | Just (i,j) <- integerLiterals args+    -> let (_,tyView -> TyConApp ubTupTcNm [liftedKi,_,intTy,_]) = splitFunForallTy ty+           (Just ubTupTc) = HashMap.lookup (nameOcc ubTupTcNm) tcm+           [ubTupDc] = tyConDataCons ubTupTc+           (d,m) = divMod i j+       in  reduce $+           mkApps (Data ubTupDc) [ Right liftedKi, Right liftedKi+                                 , Right intTy,    Right intTy+                                 , Left (Literal (IntegerLiteral d))+                                 , Left (Literal (IntegerLiteral m))+                                 ]++  "GHC.Integer.Type.gtInteger" | Just (i,j) <- integerLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i > j))++  "GHC.Integer.Type.geInteger" | Just (i,j) <- integerLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >= j))++  "GHC.Integer.Type.eqInteger" | Just (i,j) <- integerLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i == j))++  "GHC.Integer.Type.neqInteger" | Just (i,j) <- integerLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i /= j))++  "GHC.Integer.Type.ltInteger" | Just (i,j) <- integerLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i < j))++  "GHC.Integer.Type.leInteger" | Just (i,j) <- integerLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <= j))++  "GHC.Integer.Type.gtInteger#" | Just (i,j) <- integerLiterals args+    -> reduce (boolToIntLiteral (i > j))++  "GHC.Integer.Type.geInteger#" | Just (i,j) <- integerLiterals args+    -> reduce (boolToIntLiteral (i >= j))++  "GHC.Integer.Type.eqInteger#" | Just (i,j) <- integerLiterals args+    -> reduce (boolToIntLiteral (i == j))++  "GHC.Integer.Type.neqInteger#" | Just (i,j) <- integerLiterals args+    -> reduce (boolToIntLiteral (i /= j))++  "GHC.Integer.Type.ltInteger#" | Just (i,j) <- integerLiterals args+    -> reduce (boolToIntLiteral (i < j))++  "GHC.Integer.Type.leInteger#" | Just (i,j) <- integerLiterals args+    -> reduce (boolToIntLiteral (i <= j))++  "GHC.Integer.Type.shiftRInteger"+    | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+    -> reduce (integerToIntegerLiteral (i `shiftR` fromInteger j))++  "GHC.Integer.Type.shiftLInteger"+    | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+    -> reduce (integerToIntegerLiteral (i `shiftL` fromInteger j))++  "GHC.Integer.Type.wordToInteger"+    | [Lit (WordLiteral w)] <- args+    -> reduce (Literal (IntegerLiteral w))++  "GHC.Natural.NatS#"+    | [Lit (WordLiteral w)] <- args+    -> reduce (Literal (NaturalLiteral w))++  -- GHC.Real.^  -- XXX: Very fragile+  --   ^_f, $wf, $wf1 are specialisations of the internal function f in the implementation of (^) in GHC.Real+  "GHC.Real.^_f"  -- :: Integer -> Integer -> Integer+    | [Lit (IntegerLiteral i), Lit (IntegerLiteral j)] <- args+    -> reduce (integerToIntegerLiteral $ i ^ j)+  "GHC.Real.$wf"  -- :: Integer -> Int# -> Integer+    | [Lit (IntegerLiteral i), Lit (IntLiteral j)] <- args+    -> reduce (integerToIntegerLiteral $ i ^ j)+  "GHC.Real.$wf1" -- :: Int# -> Int# -> Int#+    | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args+    -> reduce (integerToIntLiteral $ i ^ j)+++  "GHC.TypeLits.natVal"+    | [Lit (NaturalLiteral n), _] <- args+    -> reduce (integerToIntegerLiteral n)++  "GHC.TypeNats.natVal"+    | [Lit (NaturalLiteral n), _] <- args+    -> reduce (Literal (NaturalLiteral n))++  "GHC.Types.C#"+    | isSubj+    , [Lit (CharLiteral c)] <- args+    ->  let (_,tyView -> TyConApp charTcNm []) = splitFunForallTy ty+            (Just charTc) = HashMap.lookup (nameOcc charTcNm) tcm+            [charDc] = tyConDataCons charTc+        in  reduce (mkApps (Data charDc) [Left (Literal (CharLiteral c))])++  "GHC.Types.I#"+    | isSubj+    , [Lit (IntLiteral i)] <- args+    ->  let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+            (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+            [intDc] = tyConDataCons intTc+        in  reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+  "GHC.Int.I8#"+    | isSubj+    , [Lit (IntLiteral i)] <- args+    ->  let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+            (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+            [intDc] = tyConDataCons intTc+        in  reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+  "GHC.Int.I16#"+    | isSubj+    , [Lit (IntLiteral i)] <- args+    ->  let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+            (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+            [intDc] = tyConDataCons intTc+        in  reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+  "GHC.Int.I32#"+    | isSubj+    , [Lit (IntLiteral i)] <- args+    ->  let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+            (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+            [intDc] = tyConDataCons intTc+        in  reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])+  "GHC.Int.I64#"+    | isSubj+    , [Lit (IntLiteral i)] <- args+    ->  let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty+            (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+            [intDc] = tyConDataCons intTc+        in  reduce (mkApps (Data intDc) [Left (Literal (IntLiteral i))])++  "GHC.Types.W#"+    | isSubj+    , [Lit (WordLiteral c)] <- args+    ->  let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+            (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm+            [wordDc] = tyConDataCons wordTc+        in  reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+  "GHC.Word.W8#"+    | isSubj+    , [Lit (WordLiteral c)] <- args+    ->  let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+            (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm+            [wordDc] = tyConDataCons wordTc+        in  reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+  "GHC.Word.W16#"+    | isSubj+    , [Lit (WordLiteral c)] <- args+    ->  let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+            (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm+            [wordDc] = tyConDataCons wordTc+        in  reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+  "GHC.Word.W32#"+    | isSubj+    , [Lit (WordLiteral c)] <- args+    ->  let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+            (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm+            [wordDc] = tyConDataCons wordTc+        in  reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])+  "GHC.Word.W64#"+    | [Lit (WordLiteral c)] <- args+    ->  let (_,tyView -> TyConApp wordTcNm []) = splitFunForallTy ty+            (Just wordTc) = HashMap.lookup (nameOcc wordTcNm) tcm+            [wordDc] = tyConDataCons wordTc+        in  reduce (mkApps (Data wordDc) [Left (Literal (WordLiteral c))])++  "GHC.Float.$w$sfromRat''" -- XXX: Very fragile+    | [Lit (IntLiteral _minEx)+      ,Lit (IntLiteral matDigs)+      ,Lit (IntegerLiteral n)+      ,Lit (IntegerLiteral d)] <- args+    -> case fromInteger matDigs of+          matDigs'+            | matDigs' == floatDigits (undefined :: Float)+            -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))+            | matDigs' == floatDigits (undefined :: Double)+            -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))+          _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"++  "GHC.Float.$w$sfromRat''1" -- XXX: Very fragile+    | [Lit (IntLiteral _minEx)+      ,Lit (IntLiteral matDigs)+      ,Lit (IntegerLiteral n)+      ,Lit (IntegerLiteral d)] <- args+    -> case fromInteger matDigs of+          matDigs'+            | matDigs' == floatDigits (undefined :: Float)+            -> reduce (Literal (FloatLiteral (toRational (fromRational (n :% d) :: Float))))+            | matDigs' == floatDigits (undefined :: Double)+            -> reduce (Literal (DoubleLiteral (toRational (fromRational (n :% d) :: Double))))+          _ -> error $ $(curLoc) ++ "GHC.Float.$w$sfromRat'': Not a Float or Double"++  "GHC.Integer.Type.doubleFromInteger"+    | [Lit (IntegerLiteral i)] <- args+    -> reduce (Literal (DoubleLiteral (toRational (fromInteger i :: Double))))++  "GHC.Base.eqString"+    | [PrimVal _ _ _ [Lit (StringLiteral s1)]+      ,PrimVal _ _ _ [Lit (StringLiteral s2)]+      ] <- args+    -> reduce (boolToBoolLiteral tcm ty (s1 == s2))+    | otherwise -> error (show args)+++  "Clash.Class.BitPack.packDouble#" -- :: Double -> BitVector 64+    | [DC _ [Left arg]] <- args+    , (h2,[],Literal (DoubleLiteral i)) <- whnf reduceConstant gbl tcm True (h,[],arg)+    -> let resTyInfo = extractTySizeInfo tcm ty tys+       in  Just (h2,k,mkBitVectorLit' resTyInfo (BitVector.unsafeToInteger $ (pack :: Double -> BitVector 64) $ fromRational i))++  "Clash.Class.BitPack.packFloat#" -- :: Float -> BitVector 32+    | [DC _ [Left arg]] <- args+    , (h2,[],Literal (FloatLiteral i)) <- whnf reduceConstant gbl tcm True (h,[],arg)+    -> let resTyInfo = extractTySizeInfo tcm ty tys+       in  Just (h2,k,mkBitVectorLit' resTyInfo (BitVector.unsafeToInteger $ (pack :: Float -> BitVector 32) $ fromRational i))++  "Clash.Class.BitPack.unpackFloat#"+    | [i] <- bitVectorLiterals' args+    -> reduce (Literal (FloatLiteral (toRational $ (unpack :: BitVector 32 -> Float) (fromInteger i))))++  "Clash.Class.BitPack.unpackDouble#"+    | [i] <- bitVectorLiterals' args+    -> reduce (Literal (DoubleLiteral (toRational $ (unpack :: BitVector 64 -> Double) (fromInteger i))))+++  "Clash.Promoted.Nat.powSNat"+    | [Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+    -> let c = case a of+                 2 -> 1 `shiftL` (fromInteger b)+                 _ -> a ^ b+           (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+           (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm+           [snatDc] = tyConDataCons snatTc+       in  reduce $+           mkApps (Data snatDc) [ Right (LitTy (NumTy c))+                                , Left (Literal (NaturalLiteral c))]++  "Clash.Promoted.Nat.flogBaseSNat"+    | [_,_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+    , Just c <- flogBase a b+    , let c' = toInteger c+    -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+           (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm+           [snatDc] = tyConDataCons snatTc+       in  reduce $+           mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+                                , Left (Literal (NaturalLiteral c'))]++  "Clash.Promoted.Nat.clogBaseSNat"+    | [_,_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+    , Just c <- clogBase a b+    , let c' = toInteger c+    -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+           (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm+           [snatDc] = tyConDataCons snatTc+       in  reduce $+           mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+                                , Left (Literal (NaturalLiteral c'))]++  "Clash.Promoted.Nat.logBaseSNat"+    | [_,Right a, Right b] <- map (runExcept . tyNatSize tcm) tys+    , Just c <- flogBase a b+    , let c' = toInteger c+    -> let (_,tyView -> TyConApp snatTcNm _) = splitFunForallTy ty+           (Just snatTc) = HashMap.lookup (nameOcc snatTcNm) tcm+           [snatDc] = tyConDataCons snatTc+       in  reduce $+           mkApps (Data snatDc) [ Right (LitTy (NumTy c'))+                                , Left (Literal (NaturalLiteral c'))]++------------+-- BitVector+------------+-- Initialisation+  "Clash.Sized.Internal.BitVector.size#"+    | Just (_, kn) <- extractKnownNat tcm tys+    -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+           (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+           [intCon] = tyConDataCons intTc+       in  reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])+  "Clash.Sized.Internal.BitVector.maxIndex#"+    | Just (_, kn) <- extractKnownNat tcm tys+    -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+           (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+           [intCon] = tyConDataCons intTc+       in  reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (kn-1)))])++-- Construction+  "Clash.Sized.Internal.BitVector.high" -- :: Bit+    -> reduce (mkBitLit ty 1)+  "Clash.Sized.Internal.BitVector.low" -- :: Bit+    -> reduce (mkBitLit ty 0)++-- Eq+  "Clash.Sized.Internal.BitVector.eq##" | [i,j] <- bitLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i == j))+  "Clash.Sized.Internal.BitVector.neq##" | [i,j] <- bitLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+  "Clash.Sized.Internal.BitVector.lt##" | [i,j] <- bitLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <  j))+  "Clash.Sized.Internal.BitVector.ge##" | [i,j] <- bitLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >= j))+  "Clash.Sized.Internal.BitVector.gt##" | [i,j] <- bitLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >  j))+  "Clash.Sized.Internal.BitVector.le##" | [i,j] <- bitLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bits+  "Clash.Sized.Internal.BitVector.and##"+    | [i,j] <- bitLiterals args+    -> reduce (mkBitLit ty (i .&. j))+  "Clash.Sized.Internal.BitVector.or##"+    | [i,j] <- bitLiterals args+    -> reduce (mkBitLit ty (i .|. j))+  "Clash.Sized.Internal.BitVector.xor##"+    | [i,j] <- bitLiterals args+    -> reduce (mkBitLit ty (i `xor` j))++  "Clash.Sized.Internal.BitVector.complement##"+    | [i] <- bitLiterals args+    -> reduce (mkBitLit ty (complement i))++-- Pack+  "Clash.Sized.Internal.BitVector.pack#"+    | [i] <- bitLiterals args+    -> let resTyInfo = extractTySizeInfo tcm ty tys+       in  reduce (mkBitVectorLit' resTyInfo i)++  "Clash.Sized.Internal.BitVector.unpack#"+    | [i] <- bitVectorLiterals' args+    -> reduce (mkBitLit ty i)++-- Concatenation+  "Clash.Sized.Internal.BitVector.++#" -- :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)+    | Just (_,m) <- extractKnownNat tcm tys+    , [i,j] <- bitVectorLiterals' args+    -> let val = i `shiftL` fromInteger m .|. j+           resTyInfo = extractTySizeInfo tcm ty tys+    in reduce (mkBitVectorLit' resTyInfo val)++-- Reduction+  "Clash.Sized.Internal.BitVector.reduceAnd#" -- :: KnownNat n => BitVector n -> Bit+    | [i] <- bitVectorLiterals' args+    , Just (_, kn) <- extractKnownNat tcm tys+    -> let resTy = getResultTy tcm ty tys+           val = reifyNat kn (op (fromInteger i))+    in reduce (mkBitLit resTy val)+    where+      op :: KnownNat n => BitVector n -> Proxy n -> Integer+      op u _ = toInteger (BitVector.reduceAnd# u)+  "Clash.Sized.Internal.BitVector.reduceOr#" -- :: KnownNat n => BitVector n -> Bit+    | [i] <- bitVectorLiterals' args+    , Just (_, kn) <- extractKnownNat tcm tys+    -> let resTy = getResultTy tcm ty tys+           val = reifyNat kn (op (fromInteger i))+    in reduce (mkBitLit resTy val)+    where+      op :: KnownNat n => BitVector n -> Proxy n -> Integer+      op u _ = toInteger (BitVector.reduceOr# u)+  "Clash.Sized.Internal.BitVector.reduceXor#" -- :: KnownNat n => BitVector n -> Bit+    | [i] <- bitVectorLiterals' args+    , Just (_, kn) <- extractKnownNat tcm tys+    -> let resTy = getResultTy tcm ty tys+           val = reifyNat kn (op (fromInteger i))+    in reduce (mkBitLit resTy val)+    where+      op :: KnownNat n => BitVector n -> Proxy n -> Integer+      op u _ = toInteger (BitVector.reduceXor# u)+++-- Indexing+  "Clash.Sized.Internal.BitVector.index#" -- :: KnownNat n => BitVector n -> Int -> Bit+    | Just (_,kn,i,j) <- bitVectorLitIntLit tcm tys args+      -> let resTy = getResultTy tcm ty tys+             val = reifyNat kn (op (fromInteger i) (fromInteger j))+         in  reduce (mkBitLit resTy val)+      where+        op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (BitVector.index# u i)+  "Clash.Sized.Internal.BitVector.replaceBit#" -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n+    | Just (_, n) <- extractKnownNat tcm tys+    , [ _+      , PrimVal bvNm _ _ [_, Lit (IntegerLiteral bv)]+      , valArgs -> Just [Literal (IntLiteral i)]+      , PrimVal bNm  _ _ [Lit (IntegerLiteral b)]+      ] <- args+    , bvNm == "Clash.Sized.Internal.BitVector.fromInteger#"+    , bNm  == "Clash.Sized.Internal.BitVector.fromInteger##"+      -> let resTyInfo = extractTySizeInfo tcm ty tys+             val = reifyNat n (op (fromInteger bv) (fromInteger i) (fromInteger b))+      in reduce (mkBitVectorLit' resTyInfo val)+      where+        op :: KnownNat n => BitVector n -> Int -> Bit -> Proxy n -> Integer+        op bv i b _ = toInteger (BitVector.replaceBit# bv i b)+  "Clash.Sized.Internal.BitVector.setSlice#"+  -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)+  -- -> BitVector (m + 1 + i)+    | mTy : _ : nTy : _ <- tys+    , Right m <- runExcept (tyNatSize tcm mTy)+    , Right n <- runExcept (tyNatSize tcm nTy)+    , [i,j] <- bitVectorLiterals' args+    -> let val = BitVector.unsafeToInteger+               $ BitVector.setSlice# (BV i) (unsafeSNat m) (unsafeSNat n) (BV j)+           resTyInfo = extractTySizeInfo tcm ty tys+       in  reduce (mkBitVectorLit' resTyInfo val)+  "Clash.Sized.Internal.BitVector.slice#"+  -- :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)+    | mTy : _ : nTy : _ <- tys+    , Right m <- runExcept (tyNatSize tcm mTy)+    , Right n <- runExcept (tyNatSize tcm nTy)+    , [i] <- bitVectorLiterals' args+    -> let val = BitVector.unsafeToInteger+               $ BitVector.slice# (BV i) (unsafeSNat m) (unsafeSNat n)+           resTyInfo = extractTySizeInfo tcm ty tys+       in  reduce (mkBitVectorLit' resTyInfo val)+  "Clash.Sized.Internal.BitVector.split#" -- :: forall n m. KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n)+    | nTy : mTy : _ <- tys+    , Right n <-  runExcept (tyNatSize tcm nTy)+    , Right m <-  runExcept (tyNatSize tcm mTy)+    , [i] <- bitVectorLiterals' args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty'+           (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc] = tyConDataCons tupTc+           bvTy : _ = tyArgs+           valM = i `shiftR` fromInteger n+           valN = i .&. mask+           mask = bit (fromInteger n) - 1+    in reduce $+       mkApps (Data tupDc) (map Right tyArgs +++                [ Left (mkBitVectorLit bvTy mTy m valM)+                , Left (mkBitVectorLit bvTy nTy n valN)])++  "Clash.Sized.Internal.BitVector.msb#" -- :: forall n. KnownNat n => BitVector n -> Bit+    | [i] <- bitVectorLiterals' args+    , Just (_, kn) <- extractKnownNat tcm tys+    -> let resTy = getResultTy tcm ty tys+           val = reifyNat kn (op (fromInteger i))+       in reduce (mkBitLit resTy val)+    where+      op :: KnownNat n => BitVector n -> Proxy n -> Integer+      op u _ = toInteger (BitVector.msb# u)+  "Clash.Sized.Internal.BitVector.lsb#" -- BitVector n -> Bit+    | [i] <- bitVectorLiterals' args+    , Just (_, kn) <- extractKnownNat tcm tys+    -> let resTy = getResultTy tcm ty tys+           val = reifyNat kn (op (fromInteger i))+    in reduce (mkBitLit resTy val)+    where+      op :: KnownNat n => BitVector n -> Proxy n -> Integer+      op u _ = toInteger (BitVector.lsb# u)+++-- Eq+  "Clash.Sized.Internal.BitVector.eq#" | Just (i,j) <- bitVectorLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i == j))+  "Clash.Sized.Internal.BitVector.neq#" | Just (i,j) <- bitVectorLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+  "Clash.Sized.Internal.BitVector.lt#" | Just (i,j) <- bitVectorLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <  j))+  "Clash.Sized.Internal.BitVector.ge#" | Just (i,j) <- bitVectorLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >= j))+  "Clash.Sized.Internal.BitVector.gt#" | Just (i,j) <- bitVectorLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >  j))+  "Clash.Sized.Internal.BitVector.le#" | Just (i,j) <- bitVectorLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+  "Clash.Sized.Internal.BitVector.minBound#"+    | Just (nTy,len) <- extractKnownNat tcm tys+    -> reduce (mkBitVectorLit ty nTy len 0)+  "Clash.Sized.Internal.BitVector.maxBound#"+    | Just (litTy,mb) <- extractKnownNat tcm tys+    -> let maxB = (2 ^ mb) - 1+       in  reduce (mkBitVectorLit ty litTy mb maxB)++-- Num+  "Clash.Sized.Internal.BitVector.+#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftBitVector2 (BitVector.+#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.BitVector.-#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftBitVector2 (BitVector.-#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.BitVector.*#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftBitVector2 (BitVector.*#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.BitVector.negate#"+    | Just (nTy, kn) <- extractKnownNat tcm tys+    , [i] <- bitVectorLiterals' args+    -> let val = reifyNat kn (op (fromInteger i))+    in reduce (mkBitVectorLit ty nTy kn val)+    where+      op :: KnownNat n => BitVector n -> Proxy n -> Integer+      op u _ = toInteger (BitVector.negate# u)++-- ExtendingNum+  "Clash.Sized.Internal.BitVector.plus#" -- :: BitVector m -> BitVector n -> BitVector (Max m n + 1)+    | Just (i,j) <- bitVectorLiterals args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+       in  reduce (mkBitVectorLit resTy resSizeTy resSizeInt (i+j))++  "Clash.Sized.Internal.BitVector.minus#"+    | [i,j] <- bitVectorLiterals' args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+           val = reifyNat resSizeInt (runSizedF (BitVector.-#) i j)+      in  reduce (mkBitVectorLit resTy resSizeTy resSizeInt val)++  "Clash.Sized.Internal.BitVector.times#"+    | Just (i,j) <- bitVectorLiterals args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+       in  reduce (mkBitVectorLit resTy resSizeTy resSizeInt (i*j))++-- Integral+  "Clash.Sized.Internal.BitVector.quot#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftBitVector2 (BitVector.quot#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.BitVector.rem#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftBitVector2 (BitVector.rem#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.BitVector.toInteger#"+    | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args+    , nm' == "Clash.Sized.Internal.BitVector.fromInteger#"+    -> reduce (integerToIntegerLiteral i)++-- Bits+  "Clash.Sized.Internal.BitVector.and#"+    | Just (i,j) <- bitVectorLiterals args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkBitVectorLit ty nTy kn (i .&. j))+  "Clash.Sized.Internal.BitVector.or#"+    | Just (i,j) <- bitVectorLiterals args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkBitVectorLit ty nTy kn (i .|. j))+  "Clash.Sized.Internal.BitVector.xor#"+    | Just (i,j) <- bitVectorLiterals args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkBitVectorLit ty nTy kn (i `xor` j))++  "Clash.Sized.Internal.BitVector.complement#"+    | [i] <- bitVectorLiterals' args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> let val = reifyNat kn (op (fromInteger i))+    in reduce (mkBitVectorLit ty nTy kn val)+    where+      op :: KnownNat n => BitVector n -> Proxy n -> Integer+      op u _ = toInteger (BitVector.complement# u)++  "Clash.Sized.Internal.BitVector.shiftL#"+    | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkBitVectorLit ty nTy kn val)+      where+        op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (BitVector.shiftL# u i)+  "Clash.Sized.Internal.BitVector.shiftR#"+    | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkBitVectorLit ty nTy kn val)+      where+        op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (BitVector.shiftR# u i)+  "Clash.Sized.Internal.BitVector.rotateL#"+    | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkBitVectorLit ty nTy kn val)+      where+        op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (BitVector.rotateL# u i)+  "Clash.Sized.Internal.BitVector.rotateR#"+    | Just (nTy,kn,i,j) <- bitVectorLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkBitVectorLit ty nTy kn val)+      where+        op :: KnownNat n => BitVector n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (BitVector.rotateR# u i)++-- Resize+  "Clash.Sized.Internal.BitVector.resize#" -- forall n m . KnownNat m => BitVector n -> BitVector m+    | _ : mTy : _ <- tys+    , Right km <- runExcept (tyNatSize tcm mTy)+    , [i] <- bitVectorLiterals' args+    -> let bitsKeep = (bit (fromInteger km)) - 1+           val = i .&. bitsKeep+    in reduce (mkBitVectorLit ty mTy km val)++--------+-- Index+--------+-- BitPack+  "Clash.Sized.Internal.Index.pack#"+    | nTy : _ <- tys+    , Right _ <- runExcept (tyNatSize tcm nTy)+    , [i] <- indexLiterals' args+    -> let resTyInfo = extractTySizeInfo tcm ty tys+       in  reduce (mkBitVectorLit' resTyInfo i)+  "Clash.Sized.Internal.Index.unpack#"+    | Just (nTy,kn) <- extractKnownNat tcm tys+    , [i] <- bitVectorLiterals' args+    -> (h,k,) <$> mkIndexLit ty nTy kn i++-- Eq+  "Clash.Sized.Internal.Index.eq#" | Just (i,j) <- indexLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i == j))+  "Clash.Sized.Internal.Index.neq#" | Just (i,j) <- indexLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+  "Clash.Sized.Internal.Index.lt#"+    | Just (i,j) <- indexLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i < j))+  "Clash.Sized.Internal.Index.ge#"+    | Just (i,j) <- indexLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >= j))+  "Clash.Sized.Internal.Index.gt#"+    | Just (i,j) <- indexLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i > j))+  "Clash.Sized.Internal.Index.le#"+    | Just (i,j) <- indexLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+  "Clash.Sized.Internal.Index.maxBound#"+    | Just (nTy,mb) <- extractKnownNat tcm tys+    -> (h,k,) <$> mkIndexLit ty nTy mb (mb - 1)++-- Num+  "Clash.Sized.Internal.Index.+#"+    | Just (nTy,kn) <- extractKnownNat tcm tys+    , [i,j] <- indexLiterals' args+    -> (h,k,) <$> mkIndexLit ty nTy kn (i + j)+  "Clash.Sized.Internal.Index.-#"+    | Just (nTy,kn) <- extractKnownNat tcm tys+    , [i,j] <- indexLiterals' args+    -> (h,k,) <$> mkIndexLit ty nTy kn (i - j)+  "Clash.Sized.Internal.Index.*#"+    | Just (nTy,kn) <- extractKnownNat tcm tys+    , [i,j] <- indexLiterals' args+    -> (h,k,) <$> mkIndexLit ty nTy kn (i * j)++-- ExtendingNum+  "Clash.Sized.Internal.Index.plus#"+    | mTy : nTy : _ <- tys+    , Right _ <- runExcept (tyNatSize tcm mTy)+    , Right _ <- runExcept (tyNatSize tcm nTy)+    , Just (i,j) <- indexLiterals args+    -> let resTyInfo = extractTySizeInfo tcm ty tys+       in  (h,k,) <$> mkIndexLit' resTyInfo (i + j)+  "Clash.Sized.Internal.Index.minus#"+    | mTy : nTy : _ <- tys+    , Right _ <- runExcept (tyNatSize tcm mTy)+    , Right _ <- runExcept (tyNatSize tcm nTy)+    , Just (i,j) <- indexLiterals args+    -> let resTyInfo = extractTySizeInfo tcm ty tys+       in  (h,k,) <$> mkIndexLit' resTyInfo (i - j)+  "Clash.Sized.Internal.Index.times#"+    | mTy : nTy : _ <- tys+    , Right _ <- runExcept (tyNatSize tcm mTy)+    , Right _ <- runExcept (tyNatSize tcm nTy)+    , Just (i,j) <- indexLiterals args+    -> let resTyInfo = extractTySizeInfo tcm ty tys+       in  (h,k,) <$> mkIndexLit' resTyInfo (i * j)++-- Integral+  "Clash.Sized.Internal.Index.quot#"+    | Just (nTy,kn) <- extractKnownNat tcm tys+    , Just (i,j) <- indexLiterals args+    -> (h,k,) <$> mkIndexLit ty nTy kn (i `quot` j)+  "Clash.Sized.Internal.Index.rem#"+    | Just (nTy,kn) <- extractKnownNat tcm tys+    , Just (i,j) <- indexLiterals args+    -> (h,k,) <$> mkIndexLit ty nTy kn (i `rem` j)+  "Clash.Sized.Internal.Index.toInteger#"+    | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args+    , nm' == "Clash.Sized.Internal.Index.fromInteger#"+    -> reduce (integerToIntegerLiteral i)++-- Resize+  "Clash.Sized.Internal.Index.resize#"+    | Just (mTy,m) <- extractKnownNat tcm tys+    , [i] <- indexLiterals' args+    -> (h,k,) <$> mkIndexLit ty mTy m i++---------+-- Signed+---------+  "Clash.Sized.Internal.Signed.size#"+    | Just (_, kn) <- extractKnownNat tcm tys+    -> let (_,tyView -> TyConApp intTcNm _) = splitFunForallTy ty+           (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+           [intCon] = tyConDataCons intTc+       in  reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])++-- BitPack+  "Clash.Sized.Internal.Signed.pack#"+    | Just (nTy, kn) <- extractKnownNat tcm tys+    , [i] <- signedLiterals' args+    -> reduce (mkBitVectorLit ty nTy kn i)+  "Clash.Sized.Internal.Signed.unpack#"+    | Just (nTy, kn) <- extractKnownNat tcm tys+    , [i] <- bitVectorLiterals' args+    -> reduce (mkSignedLit ty nTy kn i)++-- Eq+  "Clash.Sized.Internal.Signed.eq#" | Just (i,j) <- signedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i == j))+  "Clash.Sized.Internal.Signed.neq#" | Just (i,j) <- signedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+  "Clash.Sized.Internal.Signed.lt#" | Just (i,j) <- signedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <  j))+  "Clash.Sized.Internal.Signed.ge#" | Just (i,j) <- signedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >= j))+  "Clash.Sized.Internal.Signed.gt#" | Just (i,j) <- signedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >  j))+  "Clash.Sized.Internal.Signed.le#" | Just (i,j) <- signedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+  "Clash.Sized.Internal.Signed.minBound#"+    | Just (litTy,mb) <- extractKnownNat tcm tys+    -> let minB = negate (2 ^ (mb - 1))+       in  reduce (mkSignedLit ty litTy mb minB)+  "Clash.Sized.Internal.Signed.maxBound#"+    | Just (litTy,mb) <- extractKnownNat tcm tys+    -> let maxB = (2 ^ (mb - 1)) - 1+       in reduce (mkSignedLit ty litTy mb maxB)++-- Num+  "Clash.Sized.Internal.Signed.+#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftSigned2 (Signed.+#) ty tcm tys args)+    -> reduce (val)+  "Clash.Sized.Internal.Signed.-#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftSigned2 (Signed.-#) ty tcm tys args)+    -> reduce (val)+  "Clash.Sized.Internal.Signed.*#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftSigned2 (Signed.*#) ty tcm tys args)+    -> reduce (val)+  "Clash.Sized.Internal.Signed.negate#"+    | Just (nTy, kn) <- extractKnownNat tcm tys+    , [i] <- signedLiterals' args+    -> let val = reifyNat kn (op (fromInteger i))+    in reduce (mkSignedLit ty nTy kn val)+    where+      op :: KnownNat n => Signed n -> Proxy n -> Integer+      op s _ = toInteger (Signed.negate# s)+  "Clash.Sized.Internal.Signed.abs#"+    | Just (nTy, kn) <- extractKnownNat tcm tys+    , [i] <- signedLiterals' args+    -> let val = reifyNat kn (op (fromInteger i))+    in reduce (mkSignedLit ty nTy kn val)+    where+      op :: KnownNat n => Signed n -> Proxy n -> Integer+      op s _ = toInteger (Signed.abs# s)++-- ExtendingNum+  "Clash.Sized.Internal.Signed.plus#"+    | Just (i,j) <- signedLiterals args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+       in  reduce (mkSignedLit resTy resSizeTy resSizeInt (i+j))++  "Clash.Sized.Internal.Signed.minus#"+    | Just (i,j) <- signedLiterals args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+       in  reduce (mkSignedLit resTy resSizeTy resSizeInt (i-j))++  "Clash.Sized.Internal.Signed.times#"+    | Just (i,j) <- signedLiterals args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+       in  reduce (mkSignedLit resTy resSizeTy resSizeInt (i*j))++-- Integral+  "Clash.Sized.Internal.Signed.quot#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftSigned2 (Signed.quot#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Signed.rem#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftSigned2 (Signed.rem#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Signed.div#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftSigned2 (Signed.div#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Signed.mod#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftSigned2 (Signed.mod#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Signed.toInteger#"+    | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args+    , nm' == "Clash.Sized.Internal.Signed.fromInteger#"+    -> reduce (integerToIntegerLiteral i)++-- Bits+  "Clash.Sized.Internal.Signed.and#"+    | [i,j] <- signedLiterals' args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkSignedLit ty nTy kn (i .&. j))+  "Clash.Sized.Internal.Signed.or#"+    | [i,j] <- signedLiterals' args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkSignedLit ty nTy kn (i .|. j))+  "Clash.Sized.Internal.Signed.xor#"+    | [i,j] <- signedLiterals' args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkSignedLit ty nTy kn (i `xor` j))++  "Clash.Sized.Internal.Signed.complement#"+    | [i] <- signedLiterals' args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> let val = reifyNat kn (op (fromInteger i))+    in reduce (mkSignedLit ty nTy kn val)+    where+      op :: KnownNat n => Signed n -> Proxy n -> Integer+      op u _ = toInteger (Signed.complement# u)++  "Clash.Sized.Internal.Signed.shiftL#"+    | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkSignedLit ty nTy kn val)+      where+        op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (Signed.shiftL# u i)+  "Clash.Sized.Internal.Signed.shiftR#"+    | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkSignedLit ty nTy kn val)+      where+        op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (Signed.shiftR# u i)+  "Clash.Sized.Internal.Signed.rotateL#"+    | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkSignedLit ty nTy kn val)+      where+        op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (Signed.rotateL# u i)+  "Clash.Sized.Internal.Signed.rotateR#"+    | Just (nTy,kn,i,j) <- signedLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkSignedLit ty nTy kn val)+      where+        op :: KnownNat n => Signed n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (Signed.rotateR# u i)++-- Resize+  "Clash.Sized.Internal.Signed.resize#" -- forall m n. (KnownNat n, KnownNat m) => Signed n -> Signed m+    | mTy : nTy : _ <- tys+    , Right mInt <- runExcept (tyNatSize tcm mTy)+    , Right nInt <- runExcept (tyNatSize tcm nTy)+    , [i] <- signedLiterals' args+    -> let val | nInt <= mInt = extended+               | otherwise    = truncated+           extended  = i+           mask      = 1 `shiftL` fromInteger (mInt - 1)+           i'        = i `mod` mask+           truncated = if testBit i (fromInteger nInt - 1)+                          then (i' - mask)+                          else i'+       in reduce (mkSignedLit ty mTy mInt val)+  "Clash.Sized.Internal.Signed.truncateB#" -- KnownNat m => Signed (m + n) -> Signed m+    | Just (mTy, km) <- extractKnownNat tcm tys+    , [i] <- signedLiterals' args+    -> let bitsKeep = (bit (fromInteger km)) - 1+           val = i .&. bitsKeep+    in reduce (mkSignedLit ty mTy km val)++-- SaturatingNum+-- No need to manually evaluate Clash.Sized.Internal.Signed.minBoundSym#+-- It is just implemented in terms of other primitives.+++-----------+-- Unsigned+-----------+  "Clash.Sized.Internal.Unsigned.size#"+    | Just (_, kn) <- extractKnownNat tcm tys+    -> let (_,ty') = splitFunForallTy ty+           (TyConApp intTcNm _) = tyView ty'+           (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+           [intCon] = tyConDataCons intTc+       in  reduce (mkApps (Data intCon) [Left (Literal (IntLiteral kn))])++-- BitPack+  "Clash.Sized.Internal.Unsigned.pack#"+    | Just (nTy, kn) <- extractKnownNat tcm tys+    , [i] <- unsignedLiterals' args+    -> reduce (mkBitVectorLit ty nTy kn i)+  "Clash.Sized.Internal.Unsigned.unpack#"+    | Just (nTy, kn) <- extractKnownNat tcm tys+    , [i] <- bitVectorLiterals' args+    -> reduce (mkUnsignedLit ty nTy kn i)++-- Eq+  "Clash.Sized.Internal.Unsigned.eq#" | Just (i,j) <- unsignedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i == j))+  "Clash.Sized.Internal.Unsigned.neq#" | Just (i,j) <- unsignedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i /= j))++-- Ord+  "Clash.Sized.Internal.Unsigned.lt#" | Just (i,j) <- unsignedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <  j))+  "Clash.Sized.Internal.Unsigned.ge#" | Just (i,j) <- unsignedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >= j))+  "Clash.Sized.Internal.Unsigned.gt#" | Just (i,j) <- unsignedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i >  j))+  "Clash.Sized.Internal.Unsigned.le#" | Just (i,j) <- unsignedLiterals args+    -> reduce (boolToBoolLiteral tcm ty (i <= j))++-- Bounded+  "Clash.Sized.Internal.Unsigned.minBound#"+    | Just (nTy,len) <- extractKnownNat tcm tys+    -> reduce (mkUnsignedLit ty nTy len 0)+  "Clash.Sized.Internal.Unsigned.maxBound#"+    | Just (litTy,mb) <- extractKnownNat tcm tys+    -> let maxB = (2 ^ mb) - 1+       in  reduce (mkUnsignedLit ty litTy mb maxB)++-- Num+  "Clash.Sized.Internal.Unsigned.+#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.+#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Unsigned.-#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.-#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Unsigned.*#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.*#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Unsigned.negate#"+    | Just (nTy, kn) <- extractKnownNat tcm tys+    , [i] <- unsignedLiterals' args+    -> let val = reifyNat kn (op (fromInteger i))+    in reduce (mkUnsignedLit ty nTy kn val)+    where+      op :: KnownNat n => Unsigned n -> Proxy n -> Integer+      op u _ = toInteger (Unsigned.negate# u)++-- ExtendingNum+  "Clash.Sized.Internal.Unsigned.plus#" -- :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)+    | Just (i,j) <- unsignedLiterals args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+       in  reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i+j))++  "Clash.Sized.Internal.Unsigned.minus#"+    | [i,j] <- unsignedLiterals' args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+           val = reifyNat resSizeInt (runSizedF (Unsigned.-#) i j)+      in   reduce (mkUnsignedLit resTy resSizeTy resSizeInt val)++  "Clash.Sized.Internal.Unsigned.times#"+    | Just (i,j) <- unsignedLiterals args+    -> let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+           (_,resTy) = splitFunForallTy ty'+           (TyConApp _ [resSizeTy]) = tyView resTy+           Right resSizeInt = runExcept (tyNatSize tcm resSizeTy)+       in  reduce (mkUnsignedLit resTy resSizeTy resSizeInt (i*j))++-- Integral+  "Clash.Sized.Internal.Unsigned.quot#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.quot#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Unsigned.rem#"+    | Just (_, kn) <- extractKnownNat tcm tys+    , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.rem#) ty tcm tys args)+    -> reduce val+  "Clash.Sized.Internal.Unsigned.toInteger#"+    | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args+    , nm' == "Clash.Sized.Internal.Unsigned.fromInteger#"+    -> reduce (integerToIntegerLiteral i)++-- Bits+  "Clash.Sized.Internal.Unsigned.and#"+    | Just (i,j) <- unsignedLiterals args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkUnsignedLit ty nTy kn (i .&. j))+  "Clash.Sized.Internal.Unsigned.or#"+    | Just (i,j) <- unsignedLiterals args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkUnsignedLit ty nTy kn (i .|. j))+  "Clash.Sized.Internal.Unsigned.xor#"+    | Just (i,j) <- unsignedLiterals args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> reduce (mkUnsignedLit ty nTy kn (i `xor` j))++  "Clash.Sized.Internal.Unsigned.complement#"+    | [i] <- unsignedLiterals' args+    , Just (nTy, kn) <- extractKnownNat tcm tys+    -> let val = reifyNat kn (op (fromInteger i))+    in reduce (mkUnsignedLit ty nTy kn val)+    where+      op :: KnownNat n => Unsigned n -> Proxy n -> Integer+      op u _ = toInteger (Unsigned.complement# u)++  "Clash.Sized.Internal.Unsigned.shiftL#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+    | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkUnsignedLit ty nTy kn val)+      where+        op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (Unsigned.shiftL# u i)+  "Clash.Sized.Internal.Unsigned.shiftR#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+    | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkUnsignedLit ty nTy kn val)+      where+        op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (Unsigned.shiftR# u i)+  "Clash.Sized.Internal.Unsigned.rotateL#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+    | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkUnsignedLit ty nTy kn val)+      where+        op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (Unsigned.rotateL# u i)+  "Clash.Sized.Internal.Unsigned.rotateR#" -- :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n+    | Just (nTy,kn,i,j) <- unsignedLitIntLit tcm tys args+      -> let val = reifyNat kn (op (fromInteger i) (fromInteger j))+      in reduce (mkUnsignedLit ty nTy kn val)+      where+        op :: KnownNat n => Unsigned n -> Int -> Proxy n -> Integer+        op u i _ = toInteger (Unsigned.rotateR# u i)++-- Resize+  "Clash.Sized.Internal.Unsigned.resize#" -- forall n m . KnownNat m => Unsigned n -> Unsigned m+    | _ : mTy : _ <- tys+    , Right km <- runExcept (tyNatSize tcm mTy)+    , [i] <- unsignedLiterals' args+    -> let bitsKeep = (bit (fromInteger km)) - 1+           val = i .&. bitsKeep+    in reduce (mkUnsignedLit ty mTy km val)++--------+-- RTree+--------+  "Clash.Sized.RTree.textract"+    | isSubj+    , [DC _ tArgs] <- args+    -> reduceWHNF (Either.lefts tArgs !! 1)++  "Clash.Sized.RTree.tsplit"+    | isSubj+    , dTy : aTy : _ <- tys+    , [DC _ tArgs] <- args+    , (tyArgs,tyView -> TyConApp tupTcNm _) <- splitFunForallTy ty+    , TyConApp treeTcNm _ <- tyView (Either.rights tyArgs !! 0)+    -> let (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc]      = tyConDataCons tupTc+       in  reduce $+           mkApps (Data tupDc)+                  [Right (mkTyConApp treeTcNm [dTy,aTy])+                  ,Right (mkTyConApp treeTcNm [dTy,aTy])+                  ,Left (Either.lefts tArgs !! 1)+                  ,Left (Either.lefts tArgs !! 2)+                  ]++  "Clash.Sized.RTree.tdfold"+    | isSubj+    , pTy : kTy : aTy : _ <- tys+    , _ : p : f : g : ts : _ <- args+    , DC _ tArgs <- ts+    , Right k' <- runExcept (tyNatSize tcm kTy)+    -> case k' of+         0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts tArgs !! 1)])+         _ -> let k'ty = LitTy (NumTy (k'-1))+                  (tyArgs,_)  = splitFunForallTy ty+                  (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)+                  TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+                  Just snatTc = HashMap.lookup (nameOcc snatTcNm) tcm+                  [snatDc]    = tyConDataCons snatTc+              in  reduceWHNF $+                  mkApps (valToTerm g)+                         [Right k'ty+                         ,Left (mkApps (Data snatDc)+                                       [Right k'ty+                                       ,Left (Literal (NaturalLiteral (k'-1)))])+                         ,Left (mkApps (Prim nm ty)+                                       [Right pTy+                                       ,Right k'ty+                                       ,Right aTy+                                       ,Left (Literal (NaturalLiteral (k'-1)))+                                       ,Left (valToTerm p)+                                       ,Left (valToTerm f)+                                       ,Left (valToTerm g)+                                       ,Left (Either.lefts tArgs !! 1)+                                       ])+                         ,Left (mkApps (Prim nm ty)+                                       [Right pTy+                                       ,Right k'ty+                                       ,Right aTy+                                       ,Left (Literal (NaturalLiteral (k'-1)))+                                       ,Left (valToTerm p)+                                       ,Left (valToTerm f)+                                       ,Left (valToTerm g)+                                       ,Left (Either.lefts tArgs !! 2)+                                       ])+                         ]++  "Clash.Sized.RTree.treplicate"+    | isSubj+    , let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+    , (_,tyView -> TyConApp treeTcNm [lenTy,argTy]) <- splitFunForallTy ty'+    , Right len <- runExcept (tyNatSize tcm lenTy)+    -> let (Just treeTc) = HashMap.lookup (nameOcc treeTcNm) tcm+           [lrCon,brCon] = tyConDataCons treeTc+       in  reduce (mkRTree lrCon brCon argTy len (replicate (2^len) (valToTerm (last args))))++---------+-- Vector+---------+  "Clash.Sized.Vector.length"+    | isSubj+    , [nTy, _] <- tys+    , Right n <-runExcept (tyNatSize tcm nTy)+    -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty+           (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+           [intCon] = tyConDataCons intTc+       in  reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger n)))])++  "Clash.Sized.Vector.maxIndex"+    | isSubj+    , [nTy, _] <- tys+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> let (_, tyView -> TyConApp intTcNm _) = splitFunForallTy ty+           (Just intTc) = HashMap.lookup (nameOcc intTcNm) tcm+           [intCon] = tyConDataCons intTc+       in  reduce (mkApps (Data intCon) [Left (Literal (IntLiteral (toInteger (n - 1))))])++-- Indexing+  "Clash.Sized.Vector.index_int"+    | isSubj+    , nTy : aTy : _  <- tys+    , _ : xs : i : _ <- args+    , DC intDc [Left (Literal (IntLiteral i'))] <- i+    -> if i' < 0+          then Nothing+          else case xs of+                 DC _ vArgs  -> case runExcept (tyNatSize tcm nTy) of+                    Right 0  -> Nothing+                    Right n' ->+                      if i' == 0+                         then reduceWHNF (Either.lefts vArgs !! 1)+                         else reduceWHNF $+                              mkApps (Prim nm ty)+                                     [Right (LitTy (NumTy (n'-1)))+                                     ,Right aTy+                                     ,Left (Literal (NaturalLiteral (n'-1)))+                                     ,Left (Either.lefts vArgs !! 2)+                                     ,Left (mkApps (Data intDc)+                                                   [Left (Literal (IntLiteral (i'-1)))])+                                     ]+                    _ -> Nothing+                 _ -> Nothing+  "Clash.Sized.Vector.head"+    | isSubj+    , [DC _ vArgs] <- args+    -> reduceWHNF (Either.lefts vArgs !! 1)+  "Clash.Sized.Vector.last"+    | isSubj+    , [DC _ vArgs] <- args+    , (Right _ : Right aTy : Right nTy : _) <- vArgs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> if n == 0+          then reduceWHNF (Either.lefts vArgs !! 1)+          else reduceWHNF+                (mkApps (Prim nm ty) [Right (LitTy (NumTy (n-1)))+                                     ,Right aTy+                                     ,Left (Either.lefts vArgs !! 2)+                                     ])+-- - Sub-vectors+  "Clash.Sized.Vector.tail"+    | isSubj+    , [DC _ vArgs] <- args+    -> reduceWHNF (Either.lefts vArgs !! 2)+  "Clash.Sized.Vector.init"+    | isSubj+    , [DC consCon vArgs] <- args+    , (Right _ : Right aTy : Right nTy : _) <- vArgs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> if n == 0+          then reduceWHNF (Either.lefts vArgs !! 2)+          else reduce $+               mkVecCons consCon aTy n+                  (Either.lefts vArgs !! 1)+                  (mkApps (Prim nm ty) [Right (LitTy (NumTy (n-1)))+                                       ,Right aTy+                                       ,Left (Either.lefts vArgs !! 2)])+  "Clash.Sized.Vector.select"+    | isSubj+    , iTy : sTy : nTy : fTy : aTy : _ <- tys+    , eq : f : s : n : xs : _ <- args+    , Right n' <- runExcept (tyNatSize tcm nTy)+    , Right f' <- runExcept (tyNatSize tcm fTy)+    , Right i' <- runExcept (tyNatSize tcm iTy)+    , Right s' <- runExcept (tyNatSize tcm sTy)+    , DC _ vArgs <- xs+    -> case n' of+         0 -> reduce (mkVecNil nilCon aTy)+         _ -> case f' of+          0 -> let splitAtCall =+                    mkApps (Prim "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm))+                           [Right sTy+                           ,Right (LitTy (NumTy (i'-s')))+                           ,Right aTy+                           ,Left (valToTerm s)+                           ,Left (valToTerm xs)+                           ]+                   fVecTy = mkTyConApp vecTcNm [sTy,aTy]+                   iVecTy = mkTyConApp vecTcNm [LitTy (NumTy (i'-s')),aTy]+                   fNm    = string2SystemName "fxs"+                   iNm    = string2SystemName "ixs"+                   fId    = Id fNm (embed fVecTy)+                   iId    = Id iNm (embed iVecTy)+                   tupPat = (DataPat (embed tupDc) (rebind [] [fId,iId]))+                   iAlt   = bind tupPat (Var iVecTy iNm)+               in  reduce $+                   mkVecCons consCon aTy n' (Either.lefts vArgs !! 1) $+                   mkApps (Prim nm ty)+                          [Right (LitTy (NumTy (i'-s')))+                          ,Right sTy+                          ,Right (LitTy (NumTy (n'-1)))+                          ,Right (LitTy (NumTy 0))+                          ,Right aTy+                          ,Left (valToTerm eq)+                          ,Left (Literal (NaturalLiteral 0))+                          ,Left (valToTerm s)+                          ,Left (Literal (NaturalLiteral (n'-1)))+                          ,Left (Case splitAtCall iVecTy [iAlt])+                          ]+          _ -> let splitAtCall =+                    mkApps (Prim "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm))+                           [Right fTy+                           ,Right iTy+                           ,Right aTy+                           ,Left (valToTerm f)+                           ,Left (valToTerm xs)+                           ]+                   fVecTy = mkTyConApp vecTcNm [fTy,aTy]+                   iVecTy = mkTyConApp vecTcNm [iTy,aTy]+                   fNm    = string2SystemName "fxs"+                   iNm    = string2SystemName "ixs"+                   fId    = Id fNm (embed fVecTy)+                   iId    = Id iNm (embed iVecTy)+                   tupPat = (DataPat (embed tupDc) (rebind [] [fId,iId]))+                   iAlt   = bind tupPat (Var iVecTy iNm)+               in  reduceWHNF $+                   mkApps (Prim nm ty)+                     [Right iTy+                     ,Right sTy+                     ,Right nTy+                     ,Right (LitTy (NumTy 0))+                     ,Right aTy+                     ,Left (valToTerm eq)+                     ,Left (Literal (NaturalLiteral 0))+                     ,Left (valToTerm s)+                     ,Left (valToTerm n)+                     ,Left (Case splitAtCall iVecTy [iAlt])+                     ]+    where+      (tyArgs,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+      Just vecTc          = HashMap.lookup (nameOcc vecTcNm) tcm+      [nilCon,consCon]    = tyConDataCons vecTc+      TyConApp snatTcNm _ = tyView (Either.rights tyArgs !! 1)+      tupTcNm            = ghcTyconToTyConName (tupleTyCon Boxed 2)+      (Just tupTc)       = HashMap.lookup (nameOcc tupTcNm) tcm+      [tupDc]            = tyConDataCons tupTc+-- - Splitting+  "Clash.Sized.Vector.splitAt"+    | isSubj+    , DC snatDc (Right mTy:_) <- head args+    , Right m <- runExcept (tyNatSize tcm mTy)+    -> let _:nTy:aTy:_ = tys+           -- Get the tuple data-constructor+           (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc)       = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc]            = tyConDataCons tupTc+           -- Get the vector data-constructors+           TyConApp vecTcNm _ = tyView (head tyArgs)+           Just vecTc         = HashMap.lookup (nameOcc vecTcNm) tcm+           [nilCon,consCon]   = tyConDataCons vecTc+           -- Recursive call to @splitAt@+           splitAtRec v =+            mkApps (Prim nm ty)+                   [Right (LitTy (NumTy (m-1)))+                   ,Right nTy+                   ,Right aTy+                   ,Left (mkApps (Data snatDc)+                                 [ Right (LitTy (NumTy (m-1)))+                                 , Left  (Literal (NaturalLiteral (m-1)))])+                   ,Left v+                   ]+           -- Projection either the first or second field of the recursive+           -- call to @splitAt@+           splitAtSelR v = Case (splitAtRec v) (last tyArgs)+           m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]+           nVecTy  = mkTyConApp vecTcNm [nTy,aTy]+           lNm     = string2SystemName "l"+           rNm     = string2SystemName "r"+           lId     = Id lNm (embed m1VecTy)+           rId     = Id rNm (embed nVecTy)+           tupPat  = (DataPat (embed tupDc) (rebind [] [lId,rId]))+           lAlt    = bind tupPat (Var m1VecTy lNm)+           rAlt    = bind tupPat (Var nVecTy rNm)++       in case m of+         -- (Nil,v)+         0 -> reduce $+              mkApps (Data tupDc) $ (map Right tyArgs) +++                [ Left (mkVecNil nilCon aTy)+                , Left (valToTerm (last args))+                ]+         -- (x:xs) <- v+         m' | DC _ vArgs <- last args+            -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))+            -> reduce $+               mkApps (Data tupDc) $ (map Right tyArgs) +++                 [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)+                           (splitAtSelR (Either.lefts vArgs !! 2) [lAlt]))+                 , Left (splitAtSelR (Either.lefts vArgs !! 2) [rAlt])+                 ]+         -- v doesn't reduce to a data-constructor+         _  -> Nothing++  "Clash.Sized.Vector.unconcat"+    | isSubj+    , kn : snat : v : _  <- args+    , nTy : mTy : aTy :_ <- tys+    , Lit (NaturalLiteral n) <- kn+    -> let ( Either.rights -> argTys, tyView -> TyConApp vecTcNm _) =+              splitFunForallTy ty+           Just vecTc = HashMap.lookup (nameOcc vecTcNm) tcm+           [nilCon,consCon]   = tyConDataCons vecTc+           tupTcNm            = ghcTyconToTyConName (tupleTyCon Boxed 2)+           (Just tupTc)       = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc]            = tyConDataCons tupTc+           TyConApp snatTcNm _ = tyView (argTys !! 1)+           n1mTy  = mkTyConApp typeNatMul+                        [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)]+                        ,mTy]+           splitAtCall =+            mkApps (Prim "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm))+                   [Right mTy+                   ,Right n1mTy+                   ,Right aTy+                   ,Left (valToTerm snat)+                   ,Left (valToTerm v)+                   ]+           mVecTy   = mkTyConApp vecTcNm [mTy,aTy]+           n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]+           asNm     = string2SystemName "as"+           bsNm     = string2SystemName "bs"+           asId     = Id asNm (embed mVecTy)+           bsId     = Id bsNm (embed n1mVecTy)+           tupPat   = (DataPat (embed tupDc) (rebind [] [asId,bsId]))+           asAlt    = bind tupPat (Var mVecTy asNm)+           bsAlt    = bind tupPat (Var n1mVecTy bsNm)++       in  case n of+         0 -> reduce (mkVecNil nilCon mVecTy)+         _ -> reduce $+              mkVecCons consCon mVecTy n+                (Case splitAtCall mVecTy [asAlt])+                (mkApps (Prim nm ty)+                    [Right (LitTy (NumTy (n-1)))+                    ,Right mTy+                    ,Right aTy+                    ,Left (Literal (NaturalLiteral (n-1)))+                    ,Left (valToTerm snat)+                    ,Left (Case splitAtCall n1mVecTy [bsAlt])])+-- Construction+-- - initialisation+  "Clash.Sized.Vector.replicate"+    | isSubj+    , let ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+    , let (_,resTy) = splitFunForallTy ty'+    , (TyConApp vecTcNm [lenTy,argTy]) <- tyView resTy+    , Right len <- runExcept (tyNatSize tcm lenTy)+    -> let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm+           [nilCon,consCon] = tyConDataCons vecTc+       in  reduce $+           mkVec nilCon consCon argTy len+                 (replicate (fromInteger len) (valToTerm (last args)))+-- - Concatenation+  "Clash.Sized.Vector.++"+    | isSubj+    , DC dc vArgs <- head args+    , Right nTy : Right aTy : _ <- vArgs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0  -> reduce (valToTerm (last args))+         n' | (_ : _ : mTy : _) <- tys+            , Right m <- runExcept (tyNatSize tcm mTy)+            -> -- x : (xs ++ ys)+               reduce $+               mkVecCons dc aTy (n' + m) (Either.lefts vArgs !! 1)+                 (mkApps (Prim nm ty) [Right (LitTy (NumTy (n'-1)))+                                      ,Right aTy+                                      ,Right mTy+                                      ,Left (Either.lefts vArgs !! 2)+                                      ,Left (valToTerm (last args))+                                      ])+         _ -> Nothing+  "Clash.Sized.Vector.concat"+    | isSubj+    , (nTy : mTy : aTy : _)  <- tys+    , (xs : _)               <- args+    , DC dc vArgs <- xs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+        0 -> reduce (mkVecNil dc aTy)+        _ | _ : h' : t : _ <- Either.lefts  vArgs+          , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+          -> reduceWHNF $+             mkApps (Prim "Clash.Sized.Vector.++" (vecAppendTy vecTcNm))+                    [Right mTy+                    ,Right aTy+                    ,Right $ mkTyConApp typeNatMul+                      [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)], mTy]+                    ,Left h'+                    ,Left $ mkApps (Prim nm ty)+                      [ Right (LitTy (NumTy (n-1)))+                      , Right mTy+                      , Right aTy+                      , Left t+                      ]+                    ]+        _ -> Nothing++-- Modifying vectors+  "Clash.Sized.Vector.replace_int"+    | isSubj+    , nTy : aTy : _  <- tys+    , _ : xs : i : a : _ <- args+    , DC intDc [Left (Literal (IntLiteral i'))] <- i+    -> if i' < 0+          then Nothing+          else case xs of+                 DC vecTcNm vArgs -> case runExcept (tyNatSize tcm nTy) of+                    Right 0  -> Nothing+                    Right n' ->+                      if i' == 0+                         then reduce (mkVecCons vecTcNm aTy n' (valToTerm a) (Either.lefts vArgs !! 2))+                         else reduce $+                              mkVecCons vecTcNm aTy n' (Either.lefts vArgs !! 1)+                                (mkApps (Prim nm ty)+                                        [Right (LitTy (NumTy (n'-1)))+                                        ,Right aTy+                                        ,Left (Literal (NaturalLiteral (n'-1)))+                                        ,Left (Either.lefts vArgs !! 2)+                                        ,Left (mkApps (Data intDc)+                                                      [Left (Literal (IntLiteral (i'-1)))])+                                        ,Left (valToTerm a)+                                        ])+                    _ -> Nothing+                 _ -> Nothing++-- - specialised permutations+  "Clash.Sized.Vector.reverse"+    | isSubj+    , nTy : aTy : _  <- tys+    , [DC vecDc vArgs] <- args+    -> case runExcept (tyNatSize tcm nTy) of+         Right 0 -> reduce (mkVecNil vecDc aTy)+         Right n+           | (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+           , let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm+           , let [nilCon,consCon] = tyConDataCons vecTc+           -> reduceWHNF $+              mkApps (Prim "Clash.Sized.Vector.++" (vecAppendTy vecTcNm))+                [Right (LitTy (NumTy (n-1)))+                ,Right aTy+                ,Right (LitTy (NumTy 1))+                ,Left (mkApps (Prim nm ty)+                              [Right (LitTy (NumTy (n-1)))+                              ,Right aTy+                              ,Left (Either.lefts vArgs !! 2)+                              ])+                ,Left (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])+                ]+         _ -> Nothing+  "Clash.Sized.Vector.transpose" -- :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)+    | isSubj+    , nTy : mTy : aTy : _ <- tys+    , kn : xss : _ <- args+    , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+    , DC _ vArgs <- xss+    , Right n <- runExcept (tyNatSize tcm nTy)+    , Right m <- runExcept (tyNatSize tcm mTy)+    -> case m of+      0 -> let (Just vecTc)     = HashMap.lookup (nameOcc vecTcNm) tcm+               [nilCon,consCon] = tyConDataCons vecTc+           in  reduce $+               mkVec nilCon consCon (mkTyConApp vecTcNm [mTy,aTy]) n+                (replicate (fromInteger n) (mkVec nilCon consCon aTy 0 []))+      m' -> let (Just vecTc)     = HashMap.lookup (nameOcc vecTcNm) tcm+                [_,consCon] = tyConDataCons vecTc+                Just (consCoTy : _) = dataConInstArgTys consCon+                                        [mTy,aTy,LitTy (NumTy (m'-1))]+            in  reduceWHNF $+                mkApps (Prim "Clash.Sized.Vector.zipWith" (vecZipWithTy vecTcNm))+                       [ Right aTy+                       , Right (mkTyConApp vecTcNm [LitTy (NumTy (m'-1)),aTy])+                       , Right (mkTyConApp vecTcNm [mTy,aTy])+                       , Right nTy+                       , Left  (mkApps (Data consCon)+                                       [Right mTy+                                       ,Right aTy+                                       ,Right (LitTy (NumTy (m'-1)))+                                       ,Left (Prim "_CO_" consCoTy)+                                       ])+                       , Left  (Either.lefts vArgs !! 1)+                       , Left  (mkApps (Prim nm ty)+                                       [ Right nTy+                                       , Right (LitTy (NumTy (m'-1)))+                                       , Right aTy+                                       , Left  (valToTerm kn)+                                       , Left  (Either.lefts vArgs !! 2)+                                       ])+                       ]+  "Clash.Sized.Vector.rotateLeftS"+    | isSubj+    , nTy : aTy : _ : _ <- tys+    , kn : xs : d : _ <- args+    , DC dc vArgs <- xs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0  -> reduce (mkVecNil dc aTy)+         n' | DC snatDc [_,Left d'] <- d+            , (h2,[],Literal (NaturalLiteral d2)) <- whnf reduceConstant gbl tcm isSubj (h,[],d')+            -> case (d2 `mod` n) of+                 0  -> reduce (valToTerm xs)+                 d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+                           (Just vecTc)     = HashMap.lookup (nameOcc vecTcNm) tcm+                           [nilCon,consCon] = tyConDataCons vecTc+                       in  reduceWHNF' h2 $+                           mkApps (Prim nm ty)+                                  [Right nTy+                                  ,Right aTy+                                  ,Right (LitTy (NumTy (d3-1)))+                                  ,Left (valToTerm kn)+                                  ,Left (mkApps (Prim "Clash.Sized.Vector.++" (vecAppendTy vecTcNm))+                                                [Right (LitTy (NumTy (n'-1)))+                                                ,Right aTy+                                                ,Right (LitTy (NumTy 1))+                                                ,Left  (Either.lefts vArgs !! 2)+                                                ,Left  (mkVec nilCon consCon aTy 1 [Either.lefts vArgs !! 1])])+                                  ,Left (mkApps (Data snatDc)+                                                [Right (LitTy (NumTy (d3-1)))+                                                ,Left  (Literal (NaturalLiteral (d3-1)))])+                                  ]+         _  -> Nothing+  "Clash.Sized.Vector.rotateRightS"+    | isSubj+    , nTy : aTy : _ : _ <- tys+    , kn : xs : d : _ <- args+    , DC dc _ <- xs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0  -> reduce (mkVecNil dc aTy)+         n' | DC snatDc [_,Left d'] <- d+            , (h2,[],Literal (NaturalLiteral d2)) <- whnf reduceConstant gbl tcm isSubj (h,[],d')+            -> case (d2 `mod` n) of+                 0  -> reduce (valToTerm xs)+                 d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty+                       in  reduceWHNF' h2 $+                           mkApps (Prim nm ty)+                                  [Right nTy+                                  ,Right aTy+                                  ,Right (LitTy (NumTy (d3-1)))+                                  ,Left (valToTerm kn)+                                  ,Left (mkVecCons dc aTy n+                                          (mkApps (Prim "Clash.Sized.Vector.last" (vecHeadTy vecTcNm))+                                                  [Right (LitTy (NumTy (n'-1)))+                                                  ,Right aTy+                                                  ,Left  (valToTerm xs)])+                                          (mkApps (Prim "Clash.Sized.Vector.init" (vecTailTy vecTcNm))+                                                  [Right (LitTy (NumTy (n'-1)))+                                                  ,Right aTy+                                                  ,Left (valToTerm xs)]))+                                  ,Left (mkApps (Data snatDc)+                                                [Right (LitTy (NumTy (d3-1)))+                                                ,Left  (Literal (NaturalLiteral (d3-1)))])+                                  ]+         _  -> Nothing+-- Element-wise operations+-- - mapping+  "Clash.Sized.Vector.map"+    | isSubj+    , DC dc vArgs <- args !! 1+    , aTy : bTy : nTy : _ <- tys+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0  -> reduce (mkVecNil dc bTy)+         n' -> reduce $+               mkVecCons dc bTy n'+                 (mkApps (valToTerm (args !! 0)) [Left (Either.lefts vArgs !! 1)])+                 (mkApps (Prim nm ty) [Right aTy+                                      ,Right bTy+                                      ,Right (LitTy (NumTy (n' - 1)))+                                      ,Left (valToTerm (args !! 0))+                                      ,Left (Either.lefts vArgs !! 2)])+  "Clash.Sized.Vector.imap"+    | isSubj+    , nTy : aTy : bTy : _ <- tys+    , (tyArgs,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+    , let (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 1)+    , TyConApp indexTcNm _ <- tyView (Either.rights tyArgs' !! 0)+    , Right n <- runExcept (tyNatSize tcm nTy)+    , Just iLit <- mkIndexLit (Either.rights tyArgs' !! 0) nTy n 0+    -> reduceWHNF $+       mkApps (Prim "Clash.Sized.Vector.imap_go" (vecImapGoTy vecTcNm indexTcNm))+              [Right nTy+              ,Right nTy+              ,Right aTy+              ,Right bTy+              ,Left iLit+              ,Left (valToTerm (args !! 1))+              ,Left (valToTerm (args !! 2))+              ]++  "Clash.Sized.Vector.imap_go"+    | isSubj+    , nTy : mTy : aTy : bTy : _ <- tys+    , n : f : xs : _ <- args+    , DC dc vArgs <- xs+    , Right n' <- runExcept (tyNatSize tcm nTy)+    , Right m <- runExcept (tyNatSize tcm mTy)+    -> case m of+         0  -> reduce (mkVecNil dc bTy)+         m' -> let (tyArgs,_) = splitFunForallTy ty+                   TyConApp indexTcNm _ = tyView (Either.rights tyArgs !! 0)+                   Just iLit = mkIndexLit (Either.rights tyArgs !! 0) nTy n' 1+               in reduce $ mkVecCons dc bTy m'+                 (mkApps (valToTerm f) [Left (valToTerm n),Left (Either.lefts vArgs !! 1)])+                 (mkApps (Prim nm ty)+                         [Right nTy+                         ,Right (LitTy (NumTy (m'-1)))+                         ,Right aTy+                         ,Right bTy+                         ,Left (mkApps (Prim "Clash.Sized.Internal.Index.+#" (indexAddTy indexTcNm))+                                       [Right nTy+                                       ,Left (Literal (NaturalLiteral n'))+                                       ,Left (valToTerm n)+                                       ,Left iLit+                                       ])+                         ,Left (valToTerm f)+                         ,Left (Either.lefts vArgs !! 2)+                         ])++-- - Zipping+  "Clash.Sized.Vector.zipWith"+    | isSubj+    , aTy : bTy : cTy : nTy : _ <- tys+    , f : xs : ys : _   <- args+    , DC dc vArgs <- xs+    , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0  -> reduce (mkVecNil dc cTy)+         n' -> reduce $ mkVecCons dc cTy n'+                 (mkApps (valToTerm f)+                            [Left (Either.lefts vArgs !! 1)+                            ,Left (mkApps (Prim "Clash.Sized.Vector.head" (vecHeadTy vecTcNm))+                                    [Right (LitTy (NumTy (n'-1)))+                                    ,Right bTy+                                    ,Left  (valToTerm ys)+                                    ])+                            ])+                 (mkApps (Prim nm ty) [Right aTy+                                      ,Right bTy+                                      ,Right cTy+                                      ,Right (LitTy (NumTy (n' - 1)))+                                      ,Left (valToTerm f)+                                      ,Left (Either.lefts vArgs !! 2)+                                      ,Left (mkApps (Prim "Clash.Sized.Vector.tail" (vecTailTy vecTcNm))+                                                    [Right (LitTy (NumTy (n'-1)))+                                                    ,Right bTy+                                                    ,Left (valToTerm ys)+                                                    ])])++-- Folding+  "Clash.Sized.Vector.foldr"+    | isSubj+    , aTy : bTy : nTy : _ <- tys+    , f : z : xs : _ <- args+    , DC _ vArgs <- xs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0 -> reduce (valToTerm z)+         _ -> reduceWHNF $+              mkApps (valToTerm f)+                     [Left (Either.lefts vArgs !! 1)+                     ,Left (mkApps (Prim nm ty)+                                   [Right aTy+                                   ,Right bTy+                                   ,Right (LitTy (NumTy (n-1)))+                                   ,Left  (valToTerm f)+                                   ,Left  (valToTerm z)+                                   ,Left  (Either.lefts vArgs !! 2)+                                   ])+                     ]+  "Clash.Sized.Vector.fold"+    | isSubj+    , aTy : nTy : _ <- tys+    , f : vs : _ <- args+    , DC _ vArgs <- vs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0 -> reduceWHNF (Either.lefts vArgs !! 1)+         _ -> let (tyArgs,_)         = splitFunForallTy ty+                  TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 1)+                  tupTcNm      = ghcTyconToTyConName (tupleTyCon Boxed 2)+                  (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+                  [tupDc]      = tyConDataCons tupTc+                  n'     = n+1+                  m      = n' `div` 2+                  n1     = n' - m+                  mTy    = LitTy (NumTy m)+                  m'ty   = LitTy (NumTy (m-1))+                  n1mTy  = LitTy (NumTy n1)+                  n1m'ty = LitTy (NumTy (n1-1))+                  splitAtCall =+                   mkApps (Prim "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm))+                          [Right mTy+                          ,Right n1mTy+                          ,Right aTy+                          ,Left (Literal (NaturalLiteral m))+                          ,Left (valToTerm vs)+                          ]+                  mVecTy   = mkTyConApp vecTcNm [mTy,aTy]+                  n1mVecTy = mkTyConApp vecTcNm [n1mTy,aTy]+                  asNm     = string2SystemName "as"+                  bsNm     = string2SystemName "bs"+                  asId     = Id asNm (embed mVecTy)+                  bsId     = Id bsNm (embed n1mVecTy)+                  tupPat   = (DataPat (embed tupDc) (rebind [] [asId,bsId]))+                  asAlt    = bind tupPat (Var mVecTy asNm)+                  bsAlt    = bind tupPat (Var n1mVecTy bsNm)+              in  reduceWHNF $+                  mkApps (valToTerm f)+                         [Left (mkApps (Prim nm ty)+                                       [Right aTy+                                       ,Right m'ty+                                       ,Left (valToTerm f)+                                       ,Left (Case splitAtCall mVecTy [asAlt])+                                       ])+                         ,Left (mkApps (Prim nm ty)+                                       [Right aTy+                                       ,Right n1m'ty+                                       ,Left  (valToTerm f)+                                       ,Left  (Case splitAtCall n1mVecTy [bsAlt])+                                       ])+                         ]+++  "Clash.Sized.Vector.fold_split"+    | isSubj+    , mTy : nTy : aTy : _ <- tys+    , Right m <- runExcept (tyNatSize tcm mTy)+    -> let -- Get the tuple data-constructor+           (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty+           (Just tupTc)       = HashMap.lookup (nameOcc tupTcNm) tcm+           [tupDc]            = tyConDataCons tupTc+           -- Get the vector data-constructors+           TyConApp vecTcNm _ = tyView (head tyArgs)+           Just vecTc         = HashMap.lookup (nameOcc vecTcNm) tcm+           [nilCon,consCon]   = tyConDataCons vecTc+           -- Recursive call to @splitAt@+           splitAtRec v =+            mkApps (Prim nm ty)+                   [Right (LitTy (NumTy (m-1)))+                   ,Right nTy+                   ,Right aTy+                   ,Left (Literal (NaturalLiteral (m-1)))+                   ,Left v+                   ]+           -- Projection either the first or second field of the recursive+           -- call to @splitAt@+           splitAtSelR v = Case (splitAtRec v) (last tyArgs)+           m1VecTy = mkTyConApp vecTcNm [LitTy (NumTy (m-1)),aTy]+           nVecTy  = mkTyConApp vecTcNm [nTy,aTy]+           lNm     = string2SystemName "l"+           rNm     = string2SystemName "r"+           lId     = Id lNm (embed m1VecTy)+           rId     = Id rNm (embed nVecTy)+           tupPat  = (DataPat (embed tupDc) (rebind [] [lId,rId]))+           lAlt    = bind tupPat (Var m1VecTy lNm)+           rAlt    = bind tupPat (Var nVecTy rNm)+       in case m of+         -- (Nil,v)+         0 -> reduce $+              mkApps (Data tupDc) $ (map Right tyArgs) +++                [ Left (mkVecNil nilCon aTy)+                , Left (valToTerm (last args))+                ]+         -- (x:xs) <- v+         m' | DC _ vArgs <- last args+            -- (x:fst (splitAt (m-1) xs),snd (splitAt (m-1) xs))+            -> reduce $+               mkApps (Data tupDc) $ (map Right tyArgs) +++                 [ Left (mkVecCons consCon aTy m' (Either.lefts vArgs !! 1)+                           (splitAtSelR (Either.lefts vArgs !! 2) [lAlt]))+                 , Left (splitAtSelR (Either.lefts vArgs !! 2) [rAlt])+                 ]+         -- v doesn't reduce to a data-constructor+         _  -> Nothing+-- - Specialised folds+  "Clash.Sized.Vector.dfold"+    | isSubj+    , pTy : kTy : aTy : _ <- tys+    , _ : p : f : z : xs : _ <- args+    , DC _ vArgs <- xs+    , Right k' <- runExcept (tyNatSize tcm kTy)+    -> case k'  of+         0 -> reduce (valToTerm z)+         _ -> let (tyArgs,_)  = splitFunForallTy ty+                  (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 2)+                  TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+                  Just snatTc = HashMap.lookup (nameOcc snatTcNm) tcm+                  [snatDc]    = tyConDataCons snatTc+                  k'ty        = LitTy (NumTy (k'-1))+              in  reduceWHNF $+                  mkApps (valToTerm f)+                         [Right k'ty+                         ,Left (mkApps (Data snatDc)+                                       [Right k'ty+                                       ,Left (Literal (NaturalLiteral (k'-1)))])+                         ,Left (Either.lefts vArgs !! 1)+                         ,Left (mkApps (Prim nm ty)+                                       [Right pTy+                                       ,Right k'ty+                                       ,Right aTy+                                       ,Left (Literal (NaturalLiteral (k'-1)))+                                       ,Left (valToTerm p)+                                       ,Left (valToTerm f)+                                       ,Left (valToTerm z)+                                       ,Left (Either.lefts vArgs !! 2)+                                       ])+                         ]+  "Clash.Sized.Vector.dtfold"+    | isSubj+    , pTy : kTy : aTy : _ <- tys+    , _ : p : f : g : xs : _ <- args+    , DC _ vArgs <- xs+    , Right k' <- runExcept (tyNatSize tcm kTy)+    -> case k' of+         0 -> reduceWHNF (mkApps (valToTerm f) [Left (Either.lefts vArgs !! 1)])+         _ -> let (tyArgs,_)  = splitFunForallTy ty+                  TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 4)+                  (tyArgs',_) = splitFunForallTy (Either.rights tyArgs !! 3)+                  TyConApp snatTcNm _ = tyView (Either.rights tyArgs' !! 0)+                  Just snatTc = HashMap.lookup (nameOcc snatTcNm) tcm+                  [snatDc]    = tyConDataCons snatTc+                  tupTcNm     = ghcTyconToTyConName (tupleTyCon Boxed 2)+                  (Just tupTc) = HashMap.lookup (nameOcc tupTcNm) tcm+                  [tupDc]     = tyConDataCons tupTc+                  k'ty        = LitTy (NumTy (k'-1))+                  k2ty        = LitTy (NumTy (2^(k'-1)))+                  splitAtCall =+                   mkApps (Prim "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm))+                          [Right k2ty+                          ,Right k2ty+                          ,Right aTy+                          ,Left (mkApps (Data snatDc)+                                        [Right k2ty+                                        ,Left (Literal (NaturalLiteral (2^(k'-1))))])+                          ,Left (valToTerm xs)+                          ]+                  xsSVecTy = mkTyConApp vecTcNm [k2ty,aTy]+                  xsLNm    = string2SystemName "xsL"+                  xsRNm    = string2SystemName "xsR"+                  xsLId    = Id xsLNm (embed k2ty)+                  xsRId    = Id xsRNm (embed k2ty)+                  tupPat   = (DataPat (embed tupDc) (rebind [] [xsLId,xsRId]))+                  asAlt    = bind tupPat (Var k2ty xsLNm)+                  bsAlt    = bind tupPat (Var k2ty xsRNm)+              in  reduceWHNF $+                  mkApps (valToTerm g)+                         [Right k'ty+                         ,Left (mkApps (Data snatDc)+                                       [Right k'ty+                                       ,Left (Literal (NaturalLiteral (k'-1)))])+                         ,Left (mkApps (Prim nm ty)+                                       [Right pTy+                                       ,Right k'ty+                                       ,Right aTy+                                       ,Left (Literal (NaturalLiteral (k'-1)))+                                       ,Left (valToTerm p)+                                       ,Left (valToTerm f)+                                       ,Left (valToTerm g)+                                       ,Left (Case splitAtCall xsSVecTy [asAlt])])+                         ,Left (mkApps (Prim nm ty)+                                       [Right pTy+                                       ,Right k'ty+                                       ,Right aTy+                                       ,Left (Literal (NaturalLiteral (k'-1)))+                                       ,Left (valToTerm p)+                                       ,Left (valToTerm f)+                                       ,Left (valToTerm g)+                                       ,Left (Case splitAtCall xsSVecTy [bsAlt])])+                         ]+-- Misc+  "Clash.Sized.Vector.lazyV"+    | isSubj+    , nTy : aTy : _ <- tys+    , _ : xs : _ <- args+    , (_,tyView -> TyConApp vecTcNm _) <- splitFunForallTy ty+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0  -> let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm+                   [nilCon,_]   = tyConDataCons vecTc+               in  reduce (mkVecNil nilCon aTy)+         n' -> let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm+                   [_,consCon]  = tyConDataCons vecTc+               in  reduce $ mkVecCons consCon aTy n'+                     (mkApps (Prim "Clash.Sized.Vector.head" (vecHeadTy vecTcNm))+                             [ Right (LitTy (NumTy (n' - 1)))+                             , Right aTy+                             , Left  (valToTerm xs)+                             ])+                     (mkApps (Prim nm ty)+                             [ Right (LitTy (NumTy (n' - 1)))+                             , Right aTy+                             , Left  (Literal (NaturalLiteral (n'-1)))+                             , Left  (mkApps (Prim "Clash.Sized.Vector.tail" (vecTailTy vecTcNm))+                                             [ Right (LitTy (NumTy (n'-1)))+                                             , Right aTy+                                             , Left  (valToTerm xs)+                                             ])+                             ])+-- Traversable+  "Clash.Sized.Vector.traverse#"+    | isSubj+    , aTy : fTy : bTy : nTy : _ <- tys+    , apDict : f : xs : _ <- args+    , DC dc vArgs <- xs+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) tcm (valToTerm apDict) 1 1) ids+              in  reduceWHNF' (Heap h' ids') $+                  mkApps pureF+                         [Right (mkTyConApp (vecTcNm) [nTy,bTy])+                         ,Left  (mkVecNil dc bTy)]+         _ -> let ((fmapF,apF),ids') = flip runPEM ids $ do+                    fDict  <- mkSelectorCase $(curLoc) tcm (valToTerm apDict) 1 0+                    fmapF' <- mkSelectorCase $(curLoc) tcm fDict 1 0+                    apF'   <- mkSelectorCase $(curLoc) tcm (valToTerm apDict) 1 2+                    return (fmapF',apF')+                  n'ty = LitTy (NumTy (n-1))+                  Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]+              in  reduceWHNF' (Heap h' ids') $+                  mkApps apF+                         [Right (mkTyConApp vecTcNm [n'ty,bTy])+                         ,Right (mkTyConApp vecTcNm [nTy,bTy])+                         ,Left (mkApps fmapF+                                       [Right bTy+                                       ,Right (mkFunTy (mkTyConApp vecTcNm [n'ty,bTy])+                                                       (mkTyConApp vecTcNm [nTy,bTy]))+                                       ,Left (mkApps (Data dc)+                                                     [Right nTy+                                                     ,Right bTy+                                                     ,Right n'ty+                                                     ,Left (Prim "_CO_" consCoTy)])+                                       ,Left (mkApps (valToTerm f)+                                                     [Left (Either.lefts vArgs !! 1)])+                                       ])+                         ,Left (mkApps (Prim nm ty)+                                       [Right aTy+                                       ,Right fTy+                                       ,Right bTy+                                       ,Right n'ty+                                       ,Left (valToTerm apDict)+                                       ,Left (valToTerm f)+                                       ,Left (Either.lefts vArgs !! 2)+                                       ])+                         ]+    where+      (tyArgs,_)         = splitFunForallTy ty+      TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)+      Heap h' ids        = h++-- BitPack+  "Clash.Sized.Vector.concatBitVector#"+    | isSubj+    , nTy : mTy : _ <- tys+    , _  : km  : v : _ <- args+    , DC _ vArgs <- v+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0  -> let resTyInfo = extractTySizeInfo tcm ty tys+               in  reduce (mkBitVectorLit' resTyInfo 0)+         n' | Right m <- runExcept (tyNatSize tcm mTy)+            , (_,tyView -> TyConApp bvTcNm _) <- splitFunForallTy ty+            -> reduceWHNF $+               mkApps (Prim "Clash.Sized.Internal.BitVector.++#" (bvAppendTy bvTcNm))+                 [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])+                 , Right mTy+                 , Left (Literal (NaturalLiteral ((n'-1)*m)))+                 , Left (Either.lefts vArgs !! 1)+                 , Left (mkApps (Prim nm ty)+                                [ Right (LitTy (NumTy (n'-1)))+                                , Right mTy+                                , Left (Literal (NaturalLiteral (n'-1)))+                                , Left (valToTerm km)+                                , Left (Either.lefts vArgs !! 2)+                                ])+                 ]+         _ -> Nothing+  "Clash.Sized.Vector.unconcatBitVector#"+    | isSubj+    , nTy : mTy : _  <- tys+    , _  : km  : bv : _ <- args+    , (_,tyView -> TyConApp vecTcNm [_,bvMTy]) <- splitFunForallTy ty+    , TyConApp bvTcNm _ <- tyView bvMTy+    , Right n <- runExcept (tyNatSize tcm nTy)+    -> case n of+         0 ->+          let (Just vecTc) = HashMap.lookup (nameOcc vecTcNm) tcm+              [nilCon,_] = tyConDataCons vecTc+          in  reduce (mkVecNil nilCon (mkTyConApp bvTcNm [mTy]))+         n' | Right m <- runExcept (tyNatSize tcm mTy) ->+          let Just vecTc  = HashMap.lookup (nameOcc vecTcNm) tcm+              [_,consCon] = tyConDataCons vecTc+              tupTcNm     = ghcTyconToTyConName (tupleTyCon Boxed 2)+              Just tupTc  = HashMap.lookup (nameOcc tupTcNm) tcm+              [tupDc]     = tyConDataCons tupTc+              splitCall   =+                mkApps (Prim "Clash.Sized.Internal.BitVector.split#"+                             (bvSplitTy bvTcNm))+                       [ Right (mkTyConApp typeNatMul [LitTy (NumTy (n'-1)),mTy])+                       , Right mTy+                       , Left (Literal (NaturalLiteral ((n'-1)*m)))+                       , Left (valToTerm bv)+                       ]+              mBVTy       = mkTyConApp bvTcNm [mTy]+              n1BVTy      = mkTyConApp bvTcNm+                              [mkTyConApp typeNatMul+                                [LitTy (NumTy (n'-1))+                                ,mTy]]+              xNm         = string2SystemName "x"+              bvNm        = string2SystemName "bv'"+              xId         = Id xNm (embed mBVTy)+              bvId        = Id bvNm (embed n1BVTy)+              tupPat      = DataPat (embed tupDc) (rebind [] [xId,bvId])+              xAlt        = bind tupPat (Var mBVTy xNm)+              bvAlt       = bind tupPat (Var n1BVTy bvNm)++          in  reduce $ mkVecCons consCon (mkTyConApp bvTcNm [mTy]) n'+                (Case splitCall mBVTy [xAlt])+                (mkApps (Prim nm ty)+                        [ Right (LitTy (NumTy (n'-1)))+                        , Right mTy+                        , Left (Literal (NaturalLiteral (n'-1)))+                        , Left (valToTerm km)+                        , Left (Case splitCall n1BVTy [bvAlt])+                        ])+         _ -> Nothing+  _ -> Nothing+  where+    reduce = Just . (h,k,)+    reduceWHNF e = let (h2,[],e') = whnf reduceConstant gbl tcm isSubj (h,[],e)+                   in  Just (h2,k,e')+    reduceWHNF' h' e = let (h2,[],e') = whnf reduceConstant gbl tcm isSubj (h',[],e)+                       in  Just (h2,k,e')++typedLiterals' :: (Value -> Maybe a) -> [Value] -> [a]+typedLiterals' typedLiteral = mapMaybe typedLiteral++doubleLiterals' :: [Value] -> [Rational]+doubleLiterals' = typedLiterals' doubleLiteral+  where+    doubleLiteral x = case x of+      Lit (DoubleLiteral i) -> Just i+      _ -> Nothing++floatLiterals' :: [Value] -> [Rational]+floatLiterals' = typedLiterals' floatLiteral+  where+    floatLiteral x = case x of+      Lit (FloatLiteral i) -> Just i+      _ -> Nothing++integerLiterals :: [Value] -> Maybe (Integer,Integer)+integerLiterals args = case args of+  [Lit (IntegerLiteral i), Lit (IntegerLiteral j)] -> Just (i,j)+  _ -> Nothing++intLiterals :: [Value] -> Maybe (Integer,Integer)+intLiterals args = case args of+  [Lit (IntLiteral i), Lit (IntLiteral j)] -> Just (i,j)+  _ -> Nothing++intLiterals' :: [Value] -> [Integer]+intLiterals' = typedLiterals' intLiteral+  where+    intLiteral x = case x of+      Lit (IntLiteral i) -> Just i+      _ -> Nothing++intCLiterals :: [Value] -> Maybe (Integer,Integer)+intCLiterals args = case args of+  ([DC _ [Left (Literal (IntLiteral i))]+   ,DC _ [Left (Literal (IntLiteral j))]])+    -> Just (i,j)+  _ -> Nothing++wordLiterals :: [Value] -> Maybe (Integer,Integer)+wordLiterals args = case args of+  [Lit (WordLiteral i), Lit (WordLiteral j)] -> Just (i,j)+  _ -> Nothing+wordLiterals' :: [Value] -> [Integer]+wordLiterals' = typedLiterals' wordLiteral+  where+    wordLiteral x = case x of+      Lit (WordLiteral i) -> Just i+      _ -> Nothing++charLiterals :: [Value] -> Maybe (Char,Char)+charLiterals args = case args of+  [Lit (CharLiteral i), Lit (CharLiteral j)] -> Just (i,j)+  _ -> Nothing++charLiterals' :: [Value] -> [Char]+charLiterals' = typedLiterals' charLiteral+  where+    charLiteral x = case x of+      Lit (CharLiteral c) -> Just c+      _ -> Nothing++sizedLiterals :: Text -> [Value] -> Maybe (Integer,Integer)+sizedLiterals szCon args+  = case args of+      ([ PrimVal nm  _ _ [_, Lit (IntegerLiteral i)]+       , PrimVal nm' _ _ [_, Lit (IntegerLiteral j)]])+        | nm  == szCon+        , nm' == szCon -> Just (i,j)+      _ -> Nothing++sizedLiterals' :: Text -> [Value] -> [Integer]+sizedLiterals' szCon = typedLiterals' (sizedLiteral szCon)++sizedLiteral :: Text -> Value -> Maybe Integer+sizedLiteral szCon val = case val of+  PrimVal nm  _ _ [_, Lit (IntegerLiteral i)] | nm == szCon -> Just i+  _ -> Nothing++bitLiterals+  :: [Value]+  -> [Integer]+bitLiterals = typedLiterals' go+ where+  go val = case val of+    PrimVal nm _ _ [_, Lit (IntegerLiteral i)]+      | nm == "Clash.Sized.Internal.BitVector.fromInteger##"+      -> Just i+    _ -> Nothing++bitVectorLiterals, indexLiterals, signedLiterals, unsignedLiterals+  :: [Value] -> Maybe (Integer,Integer)+bitVectorLiterals = sizedLiterals "Clash.Sized.Internal.BitVector.fromInteger#"+indexLiterals     = sizedLiterals "Clash.Sized.Internal.Index.fromInteger#"+signedLiterals    = sizedLiterals "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLiterals  = sizedLiterals "Clash.Sized.Internal.Unsigned.fromInteger#"++bitVectorLiterals', indexLiterals', signedLiterals', unsignedLiterals'+  :: [Value] -> [Integer]+bitVectorLiterals' = sizedLiterals' "Clash.Sized.Internal.BitVector.fromInteger#"+indexLiterals'     = sizedLiterals' "Clash.Sized.Internal.Index.fromInteger#"+signedLiterals'    = sizedLiterals' "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLiterals'  = sizedLiterals' "Clash.Sized.Internal.Unsigned.fromInteger#"++valArgs+  :: Value+  -> Maybe [Term]+valArgs (PrimVal _ _ _ vs) = Just (map valToTerm vs)+valArgs (DC _ args)        = Just (Either.lefts args)+valArgs _                  = Nothing+++-- Tries to match literal arguments to a function like+--   (Unsigned.shiftL#  :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n)+sizedLitIntLit+  :: Text -> TyConMap -> [Type] -> [Value]+  -> Maybe (Type,Integer,Integer,Integer)+sizedLitIntLit szCon tcm tys args+  | Just (nTy,kn) <- extractKnownNat tcm tys+  , [_+    ,PrimVal nm _ _ [_,Lit (IntegerLiteral i)]+    ,valArgs -> Just [Literal (IntLiteral j)]+    ] <- args+  , nm == szCon+  = Just (nTy,kn,i,j)+  | otherwise+  = Nothing++bitVectorLitIntLit, signedLitIntLit, unsignedLitIntLit+  :: TyConMap -> [Type] -> [Value]+  -> Maybe (Type,Integer,Integer,Integer)+bitVectorLitIntLit = sizedLitIntLit "Clash.Sized.Internal.BitVector.fromInteger#"+signedLitIntLit    = sizedLitIntLit "Clash.Sized.Internal.Signed.fromInteger#"+unsignedLitIntLit  = sizedLitIntLit "Clash.Sized.Internal.Unsigned.fromInteger#"++-- From an argument list to function of type+--   forall n. KnownNat n => ...+-- extract (nTy,nInt)+-- where nTy is the Type of n+-- and   nInt is its value as an Integer+extractKnownNat :: HashMap.HashMap TyConOccName TyCon -> [Type] -> Maybe (Type, Integer)+extractKnownNat tcm tys = case tys of+  nTy : _ | Right nInt <- runExcept (tyNatSize tcm nTy)+    -> Just (nTy, nInt)+  _ -> Nothing++-- Construct a constant term of a sized type+mkSizedLit+  :: (Type -> Term)    -- type constructor?+  -> Type    -- result type+  -> Type    -- forall n.+  -> Integer -- KnownNat n+  -> Integer -- value+  -> Term+mkSizedLit conPrim ty nTy kn val+  = mkApps (conPrim sTy) [Right nTy,Left (Literal (NaturalLiteral kn)),Left (Literal (IntegerLiteral ( val)))]+  where+    (_,sTy) = splitFunForallTy ty++mkBitLit+  :: Type+  -- ^ Result type+  -> Integer+  -- ^ Value+  -> Term+mkBitLit ty val =+  mkApps (bConPrim sTy) [Left (Literal (IntegerLiteral val))]+ where+  (_,sTy) = splitFunForallTy ty++mkBitVectorLit, mkSignedLit, mkUnsignedLit+  :: Type    -- result type+  -> Type    -- forall n.+  -> Integer -- KnownNat n+  -> Integer -- value+  -> Term+mkBitVectorLit = mkSizedLit bvConPrim+mkSignedLit    = mkSizedLit signedConPrim+mkUnsignedLit  = mkSizedLit unsignedConPrim++mkIndexLit+  :: Type    -- result type+  -> Type    -- forall n.+  -> Integer -- KnownNat n+  -> Integer -- value+  -> Maybe Term+mkIndexLit rTy nTy kn val+  | val >= 0+  , val < kn+  = Just (mkSizedLit indexConPrim rTy nTy kn val)+  | otherwise+  = Nothing++-- Construct a constant term of a sized type+mkSizedLit'+  :: (Type -> Term)    -- type constructor?+  -> (Type     -- result type+     ,Type     -- forall n.+     ,Integer) -- KnownNat n+  -> Integer -- value+  -> Term+mkSizedLit' conPrim (ty,nTy,kn) val+  = mkApps (conPrim sTy) [Right nTy,Left (Literal (NaturalLiteral kn)),Left (Literal (IntegerLiteral ( val)))]+  where+    (_,sTy) = splitFunForallTy ty++mkBitVectorLit', mkSignedLit', mkUnsignedLit'+  :: (Type     -- result type+     ,Type     -- forall n.+     ,Integer) -- KnownNat n+  -> Integer -- value+  -> Term+mkBitVectorLit' = mkSizedLit' bvConPrim+mkSignedLit'    = mkSizedLit' signedConPrim+mkUnsignedLit'  = mkSizedLit' unsignedConPrim++mkIndexLit'+  :: (Type     -- result type+     ,Type     -- forall n.+     ,Integer) -- KnownNat n+  -> Integer -- value+  -> Maybe Term+mkIndexLit' res@(_,_,kn) val+  | val >= 0+  , val < kn+  = Just (mkSizedLit' indexConPrim res val)+  | otherwise+  = Nothing+++-- | 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 (Prim "_CO_" 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  (Prim "_CO_" 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)++boolToBoolLiteral :: HashMap.HashMap TyConOccName TyCon -> Type -> Bool -> Term+boolToBoolLiteral tcm ty b =+ let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty+     (Just boolTc) = HashMap.lookup (nameOcc boolTcNm) tcm+     [falseDc,trueDc] = tyConDataCons boolTc+     retDc = if b then trueDc else falseDc+ in  Data retDc++charToCharLiteral :: Char -> Term+charToCharLiteral = Literal . CharLiteral++integerToIntLiteral :: Integer -> Term+integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behaviour++integerToWordLiteral :: Integer -> Term+integerToWordLiteral = Literal . WordLiteral . toInteger . (fromInteger :: Integer -> Word) -- for overflow behaviour++integerToIntegerLiteral :: Integer -> Term+integerToIntegerLiteral = Literal . IntegerLiteral++bConPrim :: Type -> Term+bConPrim (tyView -> TyConApp bTcNm _)+  = Prim "Clash.Sized.Internal.BitVector.fromInteger##" funTy+  where+    funTy      = foldr1 mkFunTy [integerPrimTy,mkTyConApp bTcNm []]+bConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++bvConPrim :: Type -> Term+bvConPrim (tyView -> TyConApp bvTcNm _)+  = Prim "Clash.Sized.Internal.BitVector.fromInteger#" (ForAllTy (bind nTV funTy))+  where+    funTy        = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]+    nName      = string2SystemName "n"+    nVar       = VarTy typeNatKind nName+    nTV        = TyVar nName (embed typeNatKind)+bvConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++indexConPrim :: Type -> Term+indexConPrim (tyView -> TyConApp indexTcNm _)+  = Prim "Clash.Sized.Internal.Index.fromInteger#" (ForAllTy (bind nTV funTy))+  where+    funTy        = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]]+    nName      = string2SystemName "n"+    nVar       = VarTy typeNatKind nName+    nTV        = TyVar nName (embed typeNatKind)+indexConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++signedConPrim :: Type -> Term+signedConPrim (tyView -> TyConApp signedTcNm _)+  = Prim "Clash.Sized.Internal.Signed.fromInteger#" (ForAllTy (bind nTV funTy))+  where+    funTy        = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]]+    nName      = string2SystemName "n"+    nVar       = VarTy typeNatKind nName+    nTV        = TyVar nName (embed typeNatKind)+signedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"++unsignedConPrim :: Type -> Term+unsignedConPrim (tyView -> TyConApp unsignedTcNm _)+  = Prim "Clash.Sized.Internal.Unsigned.fromInteger#" (ForAllTy (bind nTV funTy))+  where+    funTy        = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]]+    nName        = string2SystemName "n"+    nVar         = VarTy typeNatKind nName+    nTV          = TyVar nName (embed typeNatKind)+unsignedConPrim _ = error $ $(curLoc) ++ "called with incorrect type"+++-- |  Lift a binary function over 'Unsigned' values to be used as literal Evaluator+--+--+liftUnsigned2 :: KnownNat n+              => (Unsigned n -> Unsigned n -> Unsigned n)+              -> Type+              -> TyConMap+              -> [Type]+              -> [Value]+              -> (Proxy n -> Maybe Term)+liftUnsigned2 = liftSized2 unsignedLiterals' mkUnsignedLit++liftSigned2 :: KnownNat n+              => (Signed n -> Signed n -> Signed n)+              -> Type+              -> TyConMap+              -> [Type]+              -> [Value]+              -> (Proxy n -> Maybe Term)+liftSigned2 = liftSized2 signedLiterals' mkSignedLit++liftBitVector2 :: KnownNat n+              => (BitVector n -> BitVector n -> BitVector n)+              -> Type+              -> TyConMap+              -> [Type]+              -> [Value]+              -> (Proxy n -> Maybe Term)+liftBitVector2 = liftSized2 bitVectorLiterals' mkBitVectorLit++liftSized2 :: (KnownNat n, Integral (sized n))+           => ([Value] -> [Integer])+              -- ^ literal argument extraction function+           -> (Type -> Type -> Integer -> Integer -> Term)+              -- ^ literal contruction function+           -> (sized n -> sized n -> sized n)+           -> Type+           -> TyConMap+           -> [Type]+           -> [Value]+           -> (Proxy n -> Maybe Term)+liftSized2 extractLitArgs mkLit f ty tcm tys args p+  | Just (nTy, kn) <- extractKnownNat tcm tys+  , [i,j] <- extractLitArgs args+  = let val = runSizedF f i j p+    in Just $ mkLit ty nTy kn val+  | otherwise = Nothing++-- | Helper to run a function over sized types on integers+--+-- This only works on function of type (sized n -> sized n -> sized n)+-- The resulting function must be executed with reifyNat+runSizedF+  :: (KnownNat n, Integral (sized n))+  => (sized n -> sized n -> sized n)   -- ^ function to run+  -> Integer                           -- ^ first  argument+  -> Integer                           -- ^ second argument+  -> (Proxy n -> Integer)+runSizedF f i j _ = toInteger $ f (fromInteger i) (fromInteger j)++extractTySizeInfo :: TyConMap -> Type -> [Type] -> (Type, Type, Integer)+extractTySizeInfo tcm ty tys = (resTy,resSizeTy,resSize)+  where+    ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+    (_,resTy) = splitFunForallTy ty'+    TyConApp _ [resSizeTy] = tyView resTy+    Right resSize = runExcept (tyNatSize tcm resSizeTy)++getResultTy+  :: TyConMap+  -> Type+  -> [Type]+  -> Type+getResultTy tcm ty tys = resTy+ where+  ty' = List.foldl' ((runFreshM .) . applyTy tcm) ty tys+  (_,resTy) = splitFunForallTy ty'++liftDDI :: (Double# -> Double# -> Int#) -> [Value] -> Maybe Term+liftDDI f args = case doubleLiterals' args of+  [i,j] -> Just $ runDDI f i j+  _     -> Nothing+liftDDD :: (Double# -> Double# -> Double#) -> [Value] -> Maybe Term+liftDDD f args = case doubleLiterals' args of+  [i,j] -> Just $ runDDD f i j+  _     -> Nothing+liftDD  :: (Double# -> Double#) -> [Value] -> Maybe Term+liftDD  f args = case doubleLiterals' args of+  [i]   -> Just $ runDD f i+  _     -> Nothing+runDDI :: (Double# -> Double# -> Int#) -> Rational -> Rational -> Term+runDDI f i j+  = let !(D# a) = fromRational i+        !(D# b) = fromRational j+        r = f a b+    in  Literal . IntLiteral . toInteger $ I# r+runDDD :: (Double# -> Double# -> Double#) -> Rational -> Rational -> Term+runDDD f i j+  = let !(D# a) = fromRational i+        !(D# b) = fromRational j+        r = f a b+    in  Literal . DoubleLiteral . toRational $ D# r+runDD :: (Double# -> Double#) -> Rational -> Term+runDD f i+  = let !(D# a) = fromRational i+        r = f a+    in  Literal . DoubleLiteral . toRational $ D# r++liftFFI :: (Float# -> Float# -> Int#) -> [Value] -> Maybe Term+liftFFI f args = case floatLiterals' args of+  [i,j] -> Just $ runFFI f i j+  _     -> Nothing+liftFFF :: (Float# -> Float# -> Float#) -> [Value] -> Maybe Term+liftFFF f args = case floatLiterals' args of+  [i,j] -> Just $ runFFF f i j+  _     -> Nothing+liftFF  :: (Float# -> Float#) -> [Value] -> Maybe Term+liftFF  f args = case floatLiterals' args of+  [i]   -> Just $ runFF f i+  _     -> Nothing+runFFI :: (Float# -> Float# -> Int#) -> Rational -> Rational -> Term+runFFI f i j+  = let !(F# a) = fromRational i+        !(F# b) = fromRational j+        r = f a b+    in  Literal . IntLiteral . toInteger $ I# r+runFFF :: (Float# -> Float# -> Float#) -> Rational -> Rational -> Term+runFFF f i j+  = let !(F# a) = fromRational i+        !(F# b) = fromRational j+        r = f a b+    in  Literal . FloatLiteral . toRational $ F# r+runFF :: (Float# -> Float#) -> Rational -> Term+runFF f i+  = let !(F# a) = fromRational i+        r = f a+    in  Literal . FloatLiteral . toRational $ F# r+++vecHeadTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+vecHeadTy vecNm =+    ForAllTy (bind nTV (+    ForAllTy (bind aTV (+    mkFunTy+      (mkTyConApp vecNm [mkTyConApp typeNatAdd+                           [VarTy typeNatKind (string2SystemName "n")+                           ,LitTy (NumTy 1)]+                        ,VarTy liftedTypeKind (string2SystemName "a")+                        ])+      (VarTy liftedTypeKind (string2SystemName "a"))))))+  where+    aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)+    nTV = TyVar (string2SystemName "n") (embed typeNatKind)++vecTailTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+vecTailTy vecNm =+    ForAllTy (bind nTV (+    ForAllTy (bind aTV (+    mkFunTy+      (mkTyConApp vecNm [mkTyConApp typeNatAdd+                           [VarTy typeNatKind (string2SystemName "n")+                           ,LitTy (NumTy 1)]+                        ,VarTy liftedTypeKind (string2SystemName "a")+                        ])+      (mkTyConApp vecNm [VarTy typeNatKind    (string2SystemName "n")+                        ,VarTy liftedTypeKind (string2SystemName "a")+                        ])))))+  where+    nTV = TyVar (string2SystemName "n") (embed typeNatKind)+    aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)++splitAtTy+  :: TyConName+  -- ^ SNat TyCon name+  -> TyConName+  -- ^ Vec TyCon name+  -> Type+splitAtTy snatNm vecNm =+  ForAllTy (bind mTV (+  ForAllTy (bind nTV (+  ForAllTy (bind aTV (+  mkFunTy+    (mkTyConApp snatNm [VarTy typeNatKind (string2SystemName "m")])+    (mkFunTy+      (mkTyConApp vecNm+                  [mkTyConApp typeNatAdd+                    [VarTy typeNatKind (string2SystemName "m")+                    ,VarTy typeNatKind (string2SystemName "n")]+                  ,VarTy liftedTypeKind (string2SystemName "a")])+      (mkTyConApp tupNm+                  [mkTyConApp vecNm+                              [VarTy typeNatKind (string2SystemName "m")+                              ,VarTy liftedTypeKind (string2SystemName "a")]+                  ,mkTyConApp vecNm+                              [VarTy typeNatKind (string2SystemName "n")+                              ,VarTy liftedTypeKind (string2SystemName "a")]]))))))))+  where+    mTV   = TyVar (string2SystemName "m") (embed typeNatKind)+    nTV   = TyVar (string2SystemName "n") (embed typeNatKind)+    aTV   = TyVar (string2SystemName "a") (embed liftedTypeKind)+    tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++foldSplitAtTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+foldSplitAtTy vecNm =+  ForAllTy (bind mTV (+  ForAllTy (bind nTV (+  ForAllTy (bind aTV (+  mkFunTy+    naturalPrimTy+    (mkFunTy+      (mkTyConApp vecNm+                  [mkTyConApp typeNatAdd+                    [VarTy typeNatKind (string2SystemName "m")+                    ,VarTy typeNatKind (string2SystemName "n")]+                  ,VarTy liftedTypeKind (string2SystemName "a")])+      (mkTyConApp tupNm+                  [mkTyConApp vecNm+                              [VarTy typeNatKind (string2SystemName "m")+                              ,VarTy liftedTypeKind (string2SystemName "a")]+                  ,mkTyConApp vecNm+                              [VarTy typeNatKind (string2SystemName "n")+                              ,VarTy liftedTypeKind (string2SystemName "a")]]))))))))+  where+    mTV   = TyVar (string2SystemName "m") (embed typeNatKind)+    nTV   = TyVar (string2SystemName "n") (embed typeNatKind)+    aTV   = TyVar (string2SystemName "a") (embed liftedTypeKind)+    tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++vecAppendTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+vecAppendTy vecNm =+    ForAllTy (bind nTV (+    ForAllTy (bind aTV (+    ForAllTy (bind mTV (+    mkFunTy+      (mkTyConApp vecNm [VarTy typeNatKind    (string2SystemName "n")+                        ,VarTy liftedTypeKind (string2SystemName "a")+                        ])+      (mkFunTy+         (mkTyConApp vecNm [VarTy typeNatKind    (string2SystemName "m")+                           ,VarTy liftedTypeKind (string2SystemName "a")+                           ])+         (mkTyConApp vecNm [mkTyConApp typeNatAdd+                              [VarTy typeNatKind (string2SystemName "n")+                              ,VarTy typeNatKind (string2SystemName "m")]+                           ,VarTy liftedTypeKind (string2SystemName "a")+                           ]))))))))+  where+    nTV = TyVar (string2SystemName "n") (embed typeNatKind)+    aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)+    mTV = TyVar (string2SystemName "m") (embed typeNatKind)++vecZipWithTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+vecZipWithTy vecNm =+  ForAllTy (bind aTV (+  ForAllTy (bind bTV (+  ForAllTy (bind cTV (+  ForAllTy (bind nTV (+  mkFunTy+    (mkFunTy aTy (mkFunTy bTy cTy))+    (mkFunTy+      (mkTyConApp vecNm [nTy,aTy])+      (mkFunTy+        (mkTyConApp vecNm [nTy,bTy])+        (mkTyConApp vecNm [nTy,cTy])))))))))))+  where+    aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)+    bTV = TyVar (string2SystemName "b") (embed liftedTypeKind)+    cTV = TyVar (string2SystemName "c") (embed liftedTypeKind)+    nTV = TyVar (string2SystemName "n") (embed typeNatKind)+    aTy = VarTy liftedTypeKind (string2SystemName "a")+    bTy = VarTy liftedTypeKind (string2SystemName "b")+    cTy = VarTy liftedTypeKind (string2SystemName "c")+    nTy = VarTy typeNatKind (string2SystemName "n")++vecImapGoTy+  :: TyConName+  -- ^ Vec TyCon name+  -> TyConName+  -- ^ Index TyCon name+  -> Type+vecImapGoTy vecTcNm indexTcNm =+  ForAllTy (bind nTV (+  ForAllTy (bind mTV (+  ForAllTy (bind aTV (+  ForAllTy (bind bTV (+  mkFunTy indexTy+    (mkFunTy fTy+       (mkFunTy vecATy vecBTy))))))))))+  where+    nTV = TyVar (string2SystemName "n") (embed typeNatKind)+    mTV = TyVar (string2SystemName "m") (embed typeNatKind)+    aTV = TyVar (string2SystemName "a") (embed liftedTypeKind)+    bTV = TyVar (string2SystemName "b") (embed liftedTypeKind)+    indexTy = mkTyConApp indexTcNm [nTy]+    nTy = VarTy typeNatKind (string2SystemName "n")+    mTy = VarTy typeNatKind (string2SystemName "m")+    fTy = mkFunTy indexTy (mkFunTy aTy bTy)+    aTy = VarTy liftedTypeKind (string2SystemName "a")+    bTy = VarTy liftedTypeKind (string2SystemName "b")+    vecATy = mkTyConApp vecTcNm [mTy,aTy]+    vecBTy = mkTyConApp vecTcNm [mTy,bTy]++indexAddTy+  :: TyConName+  -- ^ Index TyCon name+  -> Type+indexAddTy indexTcNm =+  ForAllTy (bind nTV (+  mkFunTy naturalPrimTy (mkFunTy indexTy (mkFunTy indexTy indexTy))))+  where+    nTV     = TyVar (string2SystemName "n") (embed typeNatKind)+    indexTy = mkTyConApp indexTcNm [VarTy typeNatKind (string2SystemName "n")]++++bvAppendTy+  :: TyConName+  -- ^ BitVector TyCon Name+  -> Type+bvAppendTy bvNm =+  ForAllTy (bind mTV (+  ForAllTy (bind nTV (+  mkFunTy naturalPrimTy (mkFunTy+    (mkTyConApp bvNm [VarTy typeNatKind (string2SystemName "n")])+    (mkFunTy+      (mkTyConApp bvNm [VarTy typeNatKind (string2SystemName "m")])+      (mkTyConApp bvNm [mkTyConApp typeNatAdd+                          [VarTy typeNatKind (string2SystemName "n")+                          ,VarTy typeNatKind (string2SystemName "m")]])))))))+  where+    mTV = TyVar (string2SystemName "m") (embed typeNatKind)+    nTV = TyVar (string2SystemName "n") (embed typeNatKind)++bvSplitTy+  :: TyConName+  -- ^ BitVector TyCon Name+  -> Type+bvSplitTy bvNm =+  ForAllTy (bind nTV (+  ForAllTy (bind mTV (+  mkFunTy naturalPrimTy (mkFunTy+    (mkTyConApp bvNm [mkTyConApp typeNatAdd+                                 [VarTy typeNatKind (string2SystemName "m")+                                 ,VarTy typeNatKind (string2SystemName "n")]])+    (mkTyConApp tupNm [mkTyConApp bvNm [VarTy typeNatKind (string2SystemName "m")]+                      ,mkTyConApp bvNm [VarTy typeNatKind (string2SystemName "n")]]))))))+  where+    nTV   = TyVar (string2SystemName "n") (embed typeNatKind)+    mTV   = TyVar (string2SystemName "m") (embed typeNatKind)+    tupNm = ghcTyconToTyConName (tupleTyCon Boxed 2)++typeNatAdd :: TyConName+typeNatAdd = Name User+                  (makeName "GHC.TypeNats.+"+                            (toInteger (getKey typeNatAddTyFamNameKey)))+                  wiredInSrcSpan+++typeNatMul :: TyConName+typeNatMul = Name User+                  (makeName "GHC.TypeNats.*"+                            (toInteger (getKey typeNatMulTyFamNameKey)))+                  wiredInSrcSpan++typeNatSub :: TyConName+typeNatSub = Name User+                  (makeName "GHC.TypeNats.-"+                            (toInteger (getKey typeNatSubTyFamNameKey)))+                  wiredInSrcSpan++ghcTyconToTyConName+  :: TyCon.TyCon+  -> TyConName+ghcTyconToTyConName tc =+    Name User+         (makeName n' (toInteger (getKey (TyCon.tyConUnique tc))))+         (getSrcSpan n)+  where+    n'      = fromMaybe "_INTERNAL_" (modNameM n) ++ ('.':occName)+    occName = occNameString $ nameOccName n+    n       = TyCon.tyConName tc
+ src-ghc/Clash/GHC/GHC2Core.hs view
@@ -0,0 +1,865 @@+{-|+  Copyright   :  (C) 2013-2016, University of Twente,+                     2016-2017, Myrtle Software Ltd,+                     2017     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE ViewPatterns     #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Clash.GHC.GHC2Core+  ( GHC2CoreState+  , tyConMap+  , coreToTerm+  , coreToId+  , coreToName+  , modNameM+  , qualfiedNameString+  , makeAllTyCons+  , emptyGHC2CoreState+  )+where++-- External Modules+import           Control.Lens                ((^.), (%~), (&), (%=))+import           Control.Monad.Trans.Class   (lift)+import           Control.Monad.Trans.Reader  (ReaderT)+import qualified Control.Monad.Trans.Reader  as Reader+import           Control.Monad.State         (State)+import qualified Control.Monad.State.Lazy    as State+import qualified Data.ByteString.Char8       as Char8+import           Data.Hashable               (Hashable (..))+import           Data.HashMap.Lazy           (HashMap)+import qualified Data.HashMap.Lazy           as HashMap+import qualified Data.HashMap.Strict         as HSM+import           Data.Maybe                  (catMaybes,fromMaybe,listToMaybe)+import           Data.Text                   (isInfixOf,pack)+import qualified Data.Traversable            as T+import           Unbound.Generics.LocallyNameless+  (bind, embed, rebind, rec, runFreshM, unbind, unembed)+import qualified Unbound.Generics.LocallyNameless     as Unbound++-- GHC API+import CoAxiom    (CoAxiom (co_ax_branches), CoAxBranch (cab_lhs,cab_rhs),+                   fromBranches)+import Coercion   (coercionType,coercionKind)+import CoreFVs    (exprSomeFreeVars)+import CoreSyn+  (AltCon (..), Bind (..), CoreExpr, Expr (..), Unfolding (..), collectArgs,+   rhssOfAlts, unfoldingTemplate)+import DataCon    (DataCon, dataConExTyVars,+                   dataConName, dataConRepArgTys,+                   dataConTag, dataConTyCon,+                   dataConUnivTyVars, dataConWorkId)+import DynFlags   (unsafeGlobalDynFlags)+import FamInstEnv (FamInst (..), FamInstEnvs,+                   familyInstances)+import FastString (unpackFS)+import Id         (isDataConId_maybe)+import IdInfo     (IdDetails (..), unfoldingInfo)+import Literal    (Literal (..))+import Module     (moduleName, moduleNameString)+import Name       (Name, nameModule_maybe,+                   nameOccName, nameUnique, getSrcSpan)+import PrelNames  (tYPETyConKey)+import OccName    (occNameString)+import Outputable (showPpr)+import Pair       (Pair (..))+import SrcLoc     (isGoodSrcSpan)+import TyCon      (AlgTyConRhs (..), TyCon,+                   algTyConRhs, isAlgTyCon, isFamilyTyCon,+                   isFunTyCon, isNewTyCon,+                   isPrimTyCon, isTupleTyCon,+                   isClosedSynFamilyTyConWithAxiom_maybe,+                   expandSynTyCon_maybe,+                   tyConArity,+                   tyConDataCons, tyConKind,+                   tyConName, tyConUnique)+import Type       (mkTvSubstPrs, substTy, coreView)+#if MIN_VERSION_ghc(8,2,0)+import TyCoRep    (Coercion (..), TyLit (..), Type (..))+#else+import TyCoRep    (Coercion (..), TyBinder (..), TyLit (..), Type (..))+#endif+import Unique     (Uniquable (..), Unique, getKey, hasKey)+import Var        (Id, TyVar, Var, idDetails,+                   isTyVar, varName, varType,+                   varUnique, idInfo)+#if MIN_VERSION_ghc(8,2,0)+import Var        (TyVarBndr (..))+#endif+import VarSet     (isEmptyVarSet)++-- Local imports+import qualified Clash.Core.DataCon          as C+import qualified Clash.Core.Literal          as C+import qualified Clash.Core.Name             as C+import qualified Clash.Core.Term             as C+import qualified Clash.Core.TyCon            as C+import qualified Clash.Core.Type             as C+import qualified Clash.Core.Var              as C+import           Clash.Driver.Types+import           Clash.Primitives.Types+import           Clash.Util++instance Hashable Name where+  hashWithSalt s = hashWithSalt s . getKey . nameUnique++data GHC2CoreState+  = GHC2CoreState+  { _tyConMap :: HashMap C.TyConOccName TyCon+  , _nameMap  :: HashMap Name String+  }++makeLenses ''GHC2CoreState++emptyGHC2CoreState :: GHC2CoreState+emptyGHC2CoreState = GHC2CoreState HSM.empty HSM.empty++makeAllTyCons+  :: GHC2CoreState+  -> FamInstEnvs+  -> HashMap C.TyConOccName C.TyCon+makeAllTyCons hm fiEnvs = go hm hm+  where+    go old new+        | HSM.null (new ^. tyConMap) = HSM.empty+        | otherwise                  = tcm `HSM.union` tcm'+      where+        (tcm,old') = State.runState (T.mapM (makeTyCon fiEnvs) (new ^. tyConMap)) old+        tcm'       = go old' (old' & tyConMap %~ (`HSM.difference` (old ^. tyConMap)))++makeTyCon :: FamInstEnvs+          -> TyCon+          -> State GHC2CoreState C.TyCon+makeTyCon fiEnvs tc = tycon+  where+    tycon+      | isFamilyTyCon tc    = mkFunTyCon+      | isTupleTyCon tc     = mkTupleTyCon+      | isAlgTyCon tc       = mkAlgTyCon+      | isPrimTyCon tc      = mkPrimTyCon+      | tc `hasKey` tYPETyConKey = mkSuperKindTyCon+      | otherwise           = mkVoidTyCon+      where+        tcArity = tyConArity tc++        mkAlgTyCon = do+          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+          tcKind <- coreToType (tyConKind tc)+          tcRhsM <- makeAlgTyConRhs $ algTyConRhs tc+          case tcRhsM of+            Just tcRhs ->+              return+                C.AlgTyCon+                { C.tyConName   = tcName+                , C.tyConKind   = tcKind+                , C.tyConArity  = tcArity+                , C.algTcRhs    = tcRhs+                }+            Nothing -> return (C.PrimTyCon tcName tcKind tcArity)++        mkFunTyCon = do+          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+          tcKind <- coreToType (tyConKind tc)+          substs <- case isClosedSynFamilyTyConWithAxiom_maybe tc of+            Nothing -> let instances = familyInstances fiEnvs tc+                       in  mapM famInstToSubst instances+            Just cx -> let bx = fromBranches (co_ax_branches cx)+                       in  mapM (\b -> (,) <$> mapM coreToType (cab_lhs b)+                                           <*> coreToType (cab_rhs b))+                                bx+          return+            C.FunTyCon+            { C.tyConName  = tcName+            , C.tyConKind  = tcKind+            , C.tyConArity = tcArity+            , C.tyConSubst = substs+            }++        mkTupleTyCon = do+          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+          tcKind <- coreToType (tyConKind tc)+          tcDc   <- fmap (C.DataTyCon . (:[])) . coreToDataCon . head . tyConDataCons $ tc+          return+            C.AlgTyCon+            { C.tyConName   = tcName+            , C.tyConKind   = tcKind+            , C.tyConArity  = tcArity+            , C.algTcRhs    = tcDc+            }++        mkPrimTyCon = do+          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+          tcKind <- coreToType (tyConKind tc)+          return+            C.PrimTyCon+            { C.tyConName    = tcName+            , C.tyConKind    = tcKind+            , C.tyConArity   = tcArity+            }++        mkSuperKindTyCon = do+          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+          return C.SuperKindTyCon+                   { C.tyConName = tcName+                   }++        mkVoidTyCon = do+          tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+          tcKind <- coreToType (tyConKind tc)+          return (C.PrimTyCon tcName tcKind tcArity)++        famInstToSubst :: FamInst -> State GHC2CoreState ([C.Type],C.Type)+        famInstToSubst fi = do+          tys <- mapM coreToType  (fi_tys fi)+          ty  <- coreToType (fi_rhs fi)+          return (tys,ty)++makeAlgTyConRhs :: AlgTyConRhs+                -> State GHC2CoreState (Maybe C.AlgTyConRhs)+makeAlgTyConRhs algTcRhs = case algTcRhs of+  DataTyCon dcs _ -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs+#if MIN_VERSION_ghc(8,2,0)+  SumTyCon dcs -> Just <$> C.DataTyCon <$> mapM coreToDataCon dcs+#endif+  NewTyCon dc _ (rhsTvs,rhsEtad) _ -> Just <$> (C.NewTyCon <$> coreToDataCon dc+                                                           <*> ((,) <$> mapM coreToVar rhsTvs+                                                                    <*> coreToType rhsEtad+                                                               )+                                               )+  AbstractTyCon {} -> return Nothing+  TupleTyCon {}    -> error "Cannot handle tuple tycons"++coreToTerm :: PrimMap a+           -> [Var]+           -> SrcSpan+           -> CoreExpr+           -> State GHC2CoreState C.Term+coreToTerm primMap unlocs srcsp coreExpr = Reader.runReaderT (term coreExpr) srcsp+  where+    term :: CoreExpr -> ReaderT SrcSpan (State GHC2CoreState) C.Term+    term e+      | (Var x,args) <- collectArgs e+      , let nm = State.evalState (qualfiedNameString (varName x)) emptyGHC2CoreState+      = go nm args+      | otherwise+      = term' e+      where+        -- Remove most Signal transformers+        go "Clash.Signal.Internal.mapSignal#"  args+          | length args == 5+          = term (App (args!!3) (args!!4))+        go "Clash.Signal.Internal.signal#"     args+          | length args == 3+          = term (args!!2)+        go "Clash.Signal.Internal.appSignal#"  args+          | length args == 5+          = term (App (args!!3) (args!!4))+        go "Clash.Signal.Internal.joinSignal#" args+          | length args == 3+          = term (args!!2)+        go "Clash.Signal.Bundle.vecBundle#"    args+          | length args == 4+          = term (args!!3)+        --- Remove `$`+        go "GHC.Base.$"                        args+          | length args == 5+          = term (App (args!!3) (args!!4))+        -- Remove most CallStack logic+        go "GHC.Stack.Types.PushCallStack"     args = term (last args)+        go "GHC.Stack.Types.FreezeCallStack"   args = term (last args)+        go "GHC.Stack.withFrozenCallStack"     args+          | length args == 3+          = term (App (args!!2) (args!!1))+        go _ _ = term' e+    term' (Var x)                 = do+      srcsp' <- Reader.ask+      lift (var srcsp' x)+    term' (Lit l)                 = return $ C.Literal (coreToLiteral l)+    term' (App eFun (Type tyArg)) = C.TyApp <$> term eFun <*> lift (coreToType tyArg)+    term' (App eFun eArg)         = C.App   <$> term eFun <*> term eArg+    term' (Lam x e) | isTyVar x   = C.TyLam <$> (bind <$> lift (coreToTyVar x) <*> addUsefull (getSrcSpan x) (term e))+                    | otherwise   = C.Lam   <$> (bind <$> lift (coreToId x)    <*> addUsefull (getSrcSpan x) (term e))+    term' (Let (NonRec x e1) e2)  = do+      x'  <- lift (coreToId x)+      e1' <- addUsefull (getSrcSpan x) (term e1)+      e2' <- term e2+      return $ C.Letrec $ bind (rec [(x', embed e1')]) e2'++    term' (Let (Rec xes) e) = do+      xes' <- mapM (\(x,b) -> (,) <$> lift (coreToId x)+                                  <*> addUsefull (getSrcSpan x)+                                                 (embed <$> term b))+                   xes+      e'   <- term e+      return $ C.Letrec $ bind (rec xes') e'++    term' (Case _ _ ty [])  = C.Prim (pack "EmptyCase") <$> lift (coreToType ty)+    term' (Case e b ty alts) = do+     let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (`elem` [b]))+                  $ rhssOfAlts alts+     b'  <- lift (coreToId b)+     e'  <- addUsefull (getSrcSpan b) (term e)+     ty' <- lift (coreToType ty)+     let caseTerm v = C.Case v ty' <$> mapM (addUsefull (getSrcSpan b) . alt) alts+     if usesBndr+      then do+        ct <- caseTerm (C.Var (unembed $ C.varType b') (C.varName b'))+        return $ C.Letrec $ bind (rec [(b',embed e')]) ct+      else caseTerm e'++    term' (Cast e co) = do+      let (Pair ty1 ty2) = coercionKind co+      hasPrimCoM <- lift (hasPrimCo co)+      ty1_I <- lift (isIntegerTy ty1)+      ty2_I <- lift (isIntegerTy ty2)+      case hasPrimCoM of+        Just _ | ty1_I || ty2_I+          -> C.Cast <$> term e <*> lift (coreToType ty1) <*> lift (coreToType ty2)+        _ -> term e+    term' (Tick _ e)        = term e+    term' (Type t)          = C.Prim (pack "_TY_") <$> lift (coreToType t)+    term' (Coercion co)     = C.Prim (pack "_CO_") <$> lift (coreToType (coercionType co))++    var srcsp' x = do+        xVar   <- coreToVar x+        xPrim  <- coreToPrimVar x+        let xNameS = pack $ C.name2String xPrim+        xType  <- coreToType (varType x)+        case isDataConId_maybe x of+          Just dc -> case HashMap.lookup xNameS primMap of+            Just _  -> return $ C.Prim xNameS xType+            Nothing -> if isDataConWrapId x && not (isNewTyCon (dataConTyCon dc))+              then let xInfo = idInfo x+                       unfolding = unfoldingInfo xInfo+                   in  case unfolding of+                          CoreUnfolding {} -> Reader.runReaderT (term (unfoldingTemplate unfolding)) srcsp'+                          NoUnfolding -> error ("No unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x)+                          _ -> error ("Unexpected unfolding for DC wrapper: " ++ showPpr unsafeGlobalDynFlags x)+              else C.Data <$> coreToDataCon dc+          Nothing -> case HashMap.lookup xNameS primMap of+            Just (Primitive f _)+              | f == pack "Clash.Signal.Internal.mapSignal#" -> return (mapSignalTerm xType)+              | f == pack "Clash.Signal.Internal.signal#"    -> return (signalTerm xType)+              | f == pack "Clash.Signal.Internal.appSignal#" -> return (appSignalTerm xType)+              | f == pack "Clash.Signal.Internal.traverse#"  -> return (traverseTerm xType)+              | f == pack "Clash.Signal.Internal.joinSignal#" -> return (joinTerm xType)+              | f == pack "Clash.Signal.Bundle.vecBundle#"   -> return (vecUnwrapTerm xType)+              | f == pack "GHC.Base.$"                       -> return (dollarTerm xType)+              | f == pack "GHC.Stack.withFrozenCallStack"    -> return (withFrozenCallStackTerm xType)+              | f == pack "GHC.Magic.lazy"                   -> return (idTerm xType)+              | f == pack "GHC.Magic.runRW#"                 -> return (runRWTerm xType)+              | otherwise                                    -> return (C.Prim xNameS xType)+            Just (BlackBox {}) ->+              return (C.Prim xNameS xType)+            Nothing+              | x `elem` unlocs -> return (C.Prim xNameS xType)+              | pack "$cshow" `isInfixOf` xNameS -> return (C.Prim xNameS xType)+              | otherwise       -> return  (C.Var xType xVar)++    alt (DEFAULT   , _ , e) = bind C.DefaultPat <$> term e+    alt (LitAlt l  , _ , e) = bind (C.LitPat . embed $ coreToLiteral l) <$> term e+    alt (DataAlt dc, xs, e) = case span isTyVar xs of+      (tyvs,tmvs) -> bind <$> (C.DataPat . embed <$>+                                lift (coreToDataCon dc) <*>+                                (rebind <$>+                                  lift (mapM coreToTyVar tyvs) <*>+                                  lift (mapM coreToId tmvs))) <*>+                              term e++    coreToLiteral :: Literal+                  -> C.Literal+    coreToLiteral l = case l of+      MachStr    fs  -> C.StringLiteral (Char8.unpack fs)+      MachChar   c   -> C.CharLiteral c+      MachInt    i   -> C.IntLiteral i+      MachInt64  i   -> C.IntLiteral i+      MachWord   i   -> C.WordLiteral i+      MachWord64 i   -> C.WordLiteral i+      LitInteger i _ -> C.IntegerLiteral i+      MachFloat r    -> C.FloatLiteral r+      MachDouble r   -> C.DoubleLiteral r+      MachNullAddr   -> C.StringLiteral []+      MachLabel fs _ _ -> C.StringLiteral (unpackFS fs)++addUsefull :: SrcSpan -> ReaderT SrcSpan (State GHC2CoreState) a+           -> ReaderT SrcSpan (State GHC2CoreState) a+addUsefull x = Reader.local (\r -> if isGoodSrcSpan x then x else r)++isIntegerTy :: Type -> State GHC2CoreState Bool+isIntegerTy (TyConApp tc []) = do+  tcNm <- qualfiedNameString (tyConName tc)+  return (tcNm == "GHC.Integer.Type.Integer")+isIntegerTy _ = return False++hasPrimCo :: Coercion -> State GHC2CoreState (Maybe Type)+hasPrimCo (TyConAppCo _ _ coers) = do+  tcs <- catMaybes <$> mapM hasPrimCo coers+  return (listToMaybe tcs)++hasPrimCo (AppCo co1 co2) = do+  tc1M <- hasPrimCo co1+  case tc1M of+    Just _ -> return tc1M+    _ -> hasPrimCo co2+hasPrimCo (ForAllCo _ _ co) = hasPrimCo co++hasPrimCo co@(AxiomInstCo _ _ coers) = do+    let (Pair ty1 _) = coercionKind co+    ty1PM <- isPrimTc ty1+    if ty1PM+       then return (Just ty1)+       else do+         tcs <- catMaybes <$> mapM hasPrimCo coers+         return (listToMaybe tcs)+  where+    isPrimTc (TyConApp tc _) = do+      tcNm <- qualfiedNameString (tyConName tc)+      return (tcNm `elem` ["Clash.Sized.Internal.BitVector.Bit"+                          ,"Clash.Sized.Internal.BitVector.BitVector"+                          ,"Clash.Sized.Internal.Index.Index"+                          ,"Clash.Sized.Internal.Signed.Signed"+                          ,"Clash.Sized.Internal.Unsigned.Unsigned"+                          ])+    isPrimTc _ = return False++hasPrimCo (SymCo co) = hasPrimCo co++hasPrimCo (TransCo co1 co2) = do+  tc1M <- hasPrimCo co1+  case tc1M of+    Just _ -> return tc1M+    _ -> hasPrimCo co2++hasPrimCo (AxiomRuleCo _ coers) = do+  tcs <- catMaybes <$> mapM hasPrimCo coers+  return (listToMaybe tcs)++hasPrimCo (NthCo _ co)  = hasPrimCo co+hasPrimCo (LRCo _ co)   = hasPrimCo co+hasPrimCo (InstCo co _) = hasPrimCo co+hasPrimCo (SubCo co)    = hasPrimCo co++hasPrimCo _ = return Nothing++coreToDataCon :: DataCon+              -> State GHC2CoreState C.DataCon+coreToDataCon dc = do+    repTys <- mapM coreToType (dataConRepArgTys dc)+    dcTy   <- coreToType (varType $ dataConWorkId dc)+    mkDc dcTy repTys+  where+    mkDc dcTy repTys = do+      nm   <- coreToName dataConName getUnique qualfiedNameString dc+      uTvs <- mapM coreToVar (dataConUnivTyVars dc)+      eTvs <- mapM coreToVar (dataConExTyVars dc)+      return $ C.MkData+             { C.dcName       = nm+             , C.dcTag        = dataConTag dc+             , C.dcType       = dcTy+             , C.dcArgTys     = repTys+             , C.dcUnivTyVars = uTvs+             , C.dcExtTyVars  = eTvs+             }++coreToType :: Type+           -> State GHC2CoreState C.Type+coreToType ty = coreToType' $ fromMaybe ty (coreView ty)++coreToType' :: Type+            -> State GHC2CoreState C.Type+coreToType' (TyVarTy tv) = C.VarTy <$> coreToType (varType tv) <*> (coreToVar tv)+coreToType' (TyConApp tc args)+  | isFunTyCon tc = foldl C.AppTy (C.ConstTy C.Arrow) <$> mapM coreToType args+  | otherwise     = case expandSynTyCon_maybe tc args of+                      Just (substs,synTy,remArgs) -> do+                        let substs' = mkTvSubstPrs substs+                            synTy'  = substTy substs' synTy+                        foldl C.AppTy <$> coreToType synTy' <*> mapM coreToType remArgs+                      _ -> do+                        tcName <- coreToName tyConName tyConUnique qualfiedNameString tc+                        tyConMap %= (HSM.insert (C.nameOcc tcName) tc)+                        C.mkTyConApp <$> (pure tcName) <*> mapM coreToType args+#if MIN_VERSION_ghc(8,2,0)+coreToType' (ForAllTy (TvBndr tv _) ty) = C.ForAllTy <$> (bind <$> coreToTyVar tv <*> coreToType ty)+coreToType' (FunTy ty1 ty2)             = C.mkFunTy <$> coreToType ty1 <*> coreToType ty2+#else+coreToType' (ForAllTy (Named tv _) ty) = C.ForAllTy <$> (bind <$> coreToTyVar tv <*> coreToType ty)+coreToType' (ForAllTy (Anon 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)+coreToType' t@(CoercionTy _) = error ("Cannot handle CoercionTy " ++ showPpr unsafeGlobalDynFlags t)++coreToTyLit :: TyLit+            -> C.LitTy+coreToTyLit (NumTyLit i) = C.NumTy (fromInteger i)+coreToTyLit (StrTyLit s) = C.SymTy (unpackFS s)++coreToTyVar :: TyVar+            -> State GHC2CoreState C.TyVar+coreToTyVar tv =+  C.TyVar <$> (coreToVar tv) <*> (embed <$> coreToType (varType tv))++coreToId :: Id+         -> State GHC2CoreState C.Id+coreToId i =+  C.Id <$> (coreToVar i) <*> (embed <$> coreToType (varType i))++coreToVar :: Var+          -> State GHC2CoreState (C.Name a)+coreToVar = coreToName varName varUnique qualfiedNameStringM++coreToPrimVar :: Var+              -> State GHC2CoreState (C.Name C.Term)+coreToPrimVar = coreToName varName varUnique qualfiedNameString++coreToName :: (b -> Name)+           -> (b -> Unique)+           -> (Name -> State GHC2CoreState String)+           -> b+           -> State GHC2CoreState (C.Name a)+coreToName toName toUnique toString v = do+  ns <- toString (toName v)+  let nm  = Unbound.makeName ns (toInteger . getKey . toUnique $ v)+      loc = getSrcSpan (toName v)+  return (C.Name C.User nm loc)++qualfiedNameString :: Name+                   -> State GHC2CoreState String+qualfiedNameString n = makeCached n nameMap+                     $ return (fromMaybe "_INTERNAL_" (modNameM n) ++ ('.':occName))+  where+    occName = occNameString $ nameOccName n++qualfiedNameStringM :: Name+                    -> State GHC2CoreState String+qualfiedNameStringM n = makeCached n nameMap+                      $ return (maybe occName (\modName -> modName ++ ('.':occName)) (modNameM n))+  where+    occName = occNameString $ nameOccName n++modNameM :: Name+         -> Maybe String+modNameM n = do+      module_ <- nameModule_maybe n+      let moduleNm = moduleName module_+      return (moduleNameString moduleNm)++-- | Given the type:+--+-- @forall a. forall b. forall clk. (a -> b) -> Signal' clk a -> Signal' clk b@+--+-- Generate the term:+--+-- @+-- /\(a:*)./\(b:*)./\(clk:Clock).\(f : (Signal' clk a -> Signal' clk b)).+-- \(x : Signal' clk a).f x+-- @+mapSignalTerm :: C.Type+              -> C.Term+mapSignalTerm (C.ForAllTy tvATy) =+    C.TyLam (bind aTV (+    C.TyLam (bind bTV (+    C.TyLam (bind clkTV (+    C.Lam   (bind fId (+    C.Lam   (bind xId (+    C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))+  where+    (aTV,bTV,clkTV,funTy) = runFreshM $ do+      { (aTV',C.ForAllTy tvBTy)   <- unbind tvATy+      ; (bTV',C.ForAllTy tvClkTy) <- unbind tvBTy+      ; (clkTV',funTy')           <- unbind tvClkTy+      ; return (aTV',bTV',clkTV',funTy')+      }+    (C.FunTy _ funTy'') = C.tyView funTy+    (C.FunTy aTy bTy)   = C.tyView funTy''+    fName = C.string2SystemName "f"+    xName = C.string2SystemName "x"+    fTy   = C.mkFunTy aTy bTy+    fId   = C.Id fName (embed fTy)+    xId   = C.Id xName (embed aTy)++mapSignalTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall a. forall clk. a -> Signal' clk a@+--+-- Generate the term+--+-- @/\(a:*)./\(clk:Clock).\(x:Signal' clk a).x@+signalTerm :: C.Type+           -> C.Term+signalTerm (C.ForAllTy tvATy) =+    C.TyLam (bind aTV (+    C.TyLam (bind clkTV (+    C.Lam   (bind xId (+    C.Var   aTy xName))))))+  where+    (aTV,clkTV,funTy) = runFreshM $ do+      { (aTV', C.ForAllTy tvClkTy) <- unbind tvATy+      ; (clkTV', funTy')           <- unbind tvClkTy+      ; return (aTV',clkTV',funTy')+      }+    (C.FunTy _ aTy) = C.tyView funTy+    xName = C.string2SystemName "x"+    xId   = C.Id xName (embed aTy)++signalTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @+-- forall clk. forall a. forall b. Signal' clk (a -> b) -> Signal' clk a ->+-- Signal' clk b+-- @+--+-- Generate the term:+--+-- @+-- /\(clk:Clock)./\(a:*)./\(b:*).\(f : (Signal' clk a -> Signal' clk b)).+-- \(x : Signal' clk a).f x+-- @+appSignalTerm :: C.Type+              -> C.Term+appSignalTerm (C.ForAllTy tvClkTy) =+    C.TyLam (bind clkTV (+    C.TyLam (bind aTV (+    C.TyLam (bind bTV (+    C.Lam   (bind fId (+    C.Lam   (bind xId (+    C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))+  where+    (clkTV,aTV,bTV,funTy) = runFreshM $ do+      { (clkTV',C.ForAllTy tvATy) <- unbind tvClkTy+      ; (aTV',C.ForAllTy tvBTy)   <- unbind tvATy+      ; (bTV',funTy')           <- unbind tvBTy+      ; return (clkTV',aTV',bTV',funTy')+      }+    (C.FunTy _ funTy'') = C.tyView funTy+    (C.FunTy aTy bTy)   = C.tyView funTy''+    fName = C.string2SystemName "f"+    xName = C.string2SystemName "x"+    fTy   = C.mkFunTy aTy bTy+    fId   = C.Id fName (embed fTy)+    xId   = C.Id xName (embed aTy)++appSignalTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @+-- forall t.forall n.forall a.Vec n (Signal' t a) ->+-- Signal' t (Vec n a)+-- @+--+-- Generate the term:+--+-- @+-- /\(t:Clock)./\(n:Nat)./\(a:*).\(vs:Signal' t (Vec n a)).vs+-- @+vecUnwrapTerm :: C.Type+              -> C.Term+vecUnwrapTerm (C.ForAllTy tvTTy) =+    C.TyLam (bind tTV (+    C.TyLam (bind nTV (+    C.TyLam (bind aTV (+    C.Lam   (bind vsId (+    C.Var vsTy vsName))))))))+  where+    (tTV,nTV,aTV,funTy) = runFreshM $ do+      { (tTV',C.ForAllTy tvNTy) <- unbind tvTTy+      ; (nTV',C.ForAllTy tvATy) <- unbind tvNTy+      ; (aTV',funTy')           <- unbind tvATy+      ; return (tTV',nTV',aTV',funTy')+      }+    (C.FunTy _ vsTy) = C.tyView funTy+    vsName           = C.string2SystemName "vs"+    vsId             = C.Id vsName   (embed vsTy)++vecUnwrapTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @+-- forall f.forall a.forall b.forall clk.Applicative f => (a -> f b) ->+-- CSignal clk a -> f (Signal' clk b)+-- @+--+-- Generate the term:+--+-- @+-- /\(f:* -> *)./\(a:*)./\(b:*)./\(clk:Clock).\(dict:Applicative f).+-- \(g:a -> f b).\(x:Signal' clk a).g x+-- @+traverseTerm :: C.Type+             -> C.Term+traverseTerm (C.ForAllTy tvFTy) =+    C.TyLam (bind fTV (+    C.TyLam (bind aTV (+    C.TyLam (bind bTV (+    C.TyLam (bind clkTV (+    C.Lam   (bind dictId (+    C.Lam   (bind gId (+    C.Lam   (bind xId (+    C.App (C.Var gTy gName) (C.Var xTy xName)))))))))))))))+  where+    (fTV,aTV,bTV,clkTV,funTy) = runFreshM $ do+      { (fTV',C.ForAllTy tvATy) <- unbind tvFTy+      ; (aTV',C.ForAllTy tvBTy) <- unbind tvATy+      ; (bTV',C.ForAllTy tvClkTy) <- unbind tvBTy+      ; (clkTV',funTy') <- unbind tvClkTy+      ; return (fTV',aTV',bTV',clkTV',funTy')+      }+    (C.FunTy dictTy funTy1) = C.tyView funTy+    (C.FunTy gTy    funTy2) = C.tyView funTy1+    (C.FunTy xTy    _)      = C.tyView funTy2+    dictName = C.string2SystemName "dict"+    gName    = C.string2SystemName "g"+    xName    = C.string2SystemName "x"+    dictId   = C.Id dictName (embed dictTy)+    gId      = C.Id gName (embed gTy)+    xId      = C.Id xName (embed xTy)++traverseTerm ty = error $ $(curLoc) ++ show ty++-- ∀ (r :: GHC.Types.RuntimeRep)+--   (a :: GHC.Prim.TYPE GHC.Types.PtrRepLifted)+--   (b :: GHC.Prim.TYPE r).+-- (a -> b) -> a -> b+++-- | Given the type:+--+-- @forall (r :: Rep) (a :: TYPE Lifted) (b :: TYPE r). (a -> b) -> a -> b@+--+-- Generate the term:+--+-- @/\(r:Rep)/\(a:TYPE Lifted)./\(b:TYPE r).\(f : (a -> b)).\(x : a).f x@+dollarTerm :: C.Type+           -> C.Term+dollarTerm (C.ForAllTy tvRTy) =+    C.TyLam (bind rTV (+    C.TyLam (bind aTV (+    C.TyLam (bind bTV (+    C.Lam   (bind fId (+    C.Lam   (bind xId (+    C.App (C.Var fTy fName) (C.Var aTy xName)))))))))))+  where+    (rTV,aTV,bTV,funTy) = runFreshM $ do+      { (rTV',C.ForAllTy tvATy) <- unbind tvRTy+      ; (aTV',C.ForAllTy tvBTy) <- unbind tvATy+      ; (bTV',funTy')           <- unbind tvBTy+      ; return (rTV',aTV',bTV',funTy')+      }+    (C.FunTy fTy funTy'') = C.tyView funTy+    (C.FunTy aTy _)       = C.tyView funTy''+    fName = C.string2SystemName "f"+    xName = C.string2SystemName "x"+    fId   = C.Id fName (embed fTy)+    xId   = C.Id xName (embed aTy)++dollarTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall a. forall clk. Signal' clk (Signal' clk a) -> Signal' clk a@+--+-- Generate the term+--+-- @/\(a:*)./\(clk:Clock).\(x:Signal' clk a).x@+joinTerm :: C.Type+         -> C.Term+joinTerm ty@(C.ForAllTy _) = signalTerm ty+joinTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall a. CallStack -> (HasCallStack => a) -> a@+--+-- Generate the term+--+-- @/\(a:*)./\(callStack:CallStack).\(f:HasCallStack => a).f callStack@+withFrozenCallStackTerm+  :: C.Type+  -> C.Term+withFrozenCallStackTerm (C.ForAllTy tvATy) =+  C.TyLam (bind aTV (+  C.Lam   (bind callStackId (+  C.Lam   (bind fId (+  C.App (C.Var fTy fName) (C.Var callStackTy callStackName)))))))+  where+    (aTV,funTy) = runFreshM (unbind tvATy)+    (C.FunTy callStackTy fTy) = C.tyView funTy+    callStackName = C.string2SystemName "callStack"+    fName         = C.string2SystemName "f"+    callStackId   = C.Id callStackName (embed callStackTy)+    fId           = C.Id fName (embed fTy)++withFrozenCallStackTerm ty = error $ $(curLoc) ++ show ty++-- | Given the type:+--+-- @forall a. a -> a@+--+-- Generate the term+--+-- @/\(a:*).\(x:a).x@+idTerm+  :: C.Type+  -> C.Term+idTerm (C.ForAllTy tvATy) =+  C.TyLam (bind aTV (+  C.Lam   (bind xId (+  C.Var xTy xName))))+  where+    (aTV,funTy)     = runFreshM (unbind tvATy)+    (C.FunTy xTy _) = C.tyView funTy+    xName           = C.string2SystemName "x"+    xId             = C.Id xName (embed xTy)++idTerm ty = error $ $(curLoc) ++ show ty++-- | Given type type:+--+-- @forall (r :: RuntimeRep) (o :: TYPE r).(State# RealWorld -> o) -> o@+--+-- Genereate the term:+--+-- @/\(r:RuntimeRep)./\(o:TYPE r).\(f:State# RealWord -> o) -> f realWorld#@+runRWTerm+  :: C.Type+  -> C.Term+runRWTerm (C.ForAllTy tvRTy) =+  C.TyLam (bind rTV (+  C.TyLam (bind oTV (+  C.Lam   (bind fId (+  (C.App (C.Var fTy fName) (C.Prim rwNm rwTy))))))))+  where+    (rTV,oTV,funTy) = runFreshM $ do+      { (rTV',C.ForAllTy tvOTy) <- unbind tvRTy+      ; (oTV',funTy')           <- unbind tvOTy+      ; return (rTV',oTV',funTy')+      }+    (C.FunTy fTy _)  = C.tyView funTy+    (C.FunTy rwTy _) = C.tyView fTy+    fName            = C.string2SystemName "f"+    fId              = C.Id fName (embed fTy)+    rwNm             = pack "Clash.GHC.GHC2Core.realWorld#"++runRWTerm ty = error $ $(curLoc) ++ show ty++isDataConWrapId :: Id -> Bool+isDataConWrapId v = case idDetails v of+  DataConWrapId {} -> True+  _                -> False
+ src-ghc/Clash/GHC/GenerateBindings.hs view
@@ -0,0 +1,200 @@+{-|+  Copyright   :  (C) 2013-2016, University of Twente,+                          2017, QBayLogic, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE LambdaCase   #-}+{-# LANGUAGE ViewPatterns #-}++module Clash.GHC.GenerateBindings+  (generateBindings)+where++import           Control.Lens            ((%~),(&),(^.),_1,_2)+import           Control.Monad.State     (State)+import qualified Control.Monad.State     as State+import           Data.Either             (lefts, rights)+import           Data.HashMap.Strict     (HashMap)+import qualified Data.HashMap.Strict     as HashMap+import           Data.IntMap.Strict      (IntMap)+import qualified Data.IntMap.Strict      as IM+import           Data.List               (foldl')+import           Data.Text.Lazy          (Text)+import qualified Data.Set                as Set+import qualified Data.Set.Lens           as Lens+import           Unbound.Generics.LocallyNameless (bind,embed,rec,runFreshM,unembed)++import qualified BasicTypes              as GHC+import qualified CoreSyn                 as GHC+import qualified DynFlags                as GHC+import qualified IdInfo                  as GHC+import qualified Name                    as GHC hiding (varName)+import qualified TyCon                   as GHC+import qualified TysWiredIn              as GHC+import qualified Var                     as GHC+import qualified SrcLoc                  as GHC++import           Clash.Annotations.TopEntity (TopEntity)+import           Clash.Annotations.Primitive (HDL)+import           Clash.Core.FreeVars     (termFreeIds)+import           Clash.Core.Name         (Name (..), string2SystemName)+import           Clash.Core.Term         (Term (..), TmName, TmOccName)+import           Clash.Core.Type         (Type, TypeView (..), mkFunTy, splitFunForallTy, tyView)+import           Clash.Core.TyCon        (TyCon, TyConName, TyConOccName)+import           Clash.Core.TysPrim      (tysPrimMap)+import           Clash.Core.Subst        (substTms)+import           Clash.Core.Util         (mkLams, mkTyLams, termType)+import           Clash.Core.Var          (Var (..))+import           Clash.Driver.Types      (BindingMap)+import           Clash.GHC.GHC2Core      (GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm,+                                          makeAllTyCons, qualfiedNameString, emptyGHC2CoreState)+import           Clash.GHC.LoadModules   (loadModules)+import           Clash.Primitives.Types  (PrimMap)+import           Clash.Primitives.Util   (generatePrimMap)+import           Clash.Rewrite.Util      (mkInternalVar, mkSelectorCase)+import           Clash.Util              ((***),first)++generateBindings ::+     [FilePath]  -- ^ primitives (blackbox) directory+  -> [FilePath]+  -> HDL+  -> String+  -> Maybe  (GHC.DynFlags)+  -> IO (BindingMap,HashMap TyConOccName TyCon,IntMap TyConName+        ,[( TmName          -- topEntity bndr+          , Type            -- type of the topEntity bndr+          , Maybe TopEntity -- (maybe) TopEntity annotation+          , Maybe TmName)]  -- (maybe) associated testbench+        ,PrimMap Text)      -- The primitives found in '.' and 'primDir'+generateBindings primDirs importDirs hdl modName dflagsM = do+  (bindings,clsOps,unlocatable,fiEnvs,topEntities,pFP) <- loadModules hdl modName dflagsM+  primMap <- generatePrimMap $ concat [pFP, primDirs, importDirs]+  let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState+      (tcMap',tupTcCache)           = mkTupTyCons tcMap+      tcCache                       = makeAllTyCons tcMap' fiEnvs+      allTcCache                    = tysPrimMap `HashMap.union` tcCache+      clsMap                        = HashMap.map (\(nm,ty,i) -> (nm,ty,GHC.noSrcSpan,GHC.Inline,mkClassSelector allTcCache ty i)) clsVMap+      allBindings                   = bindingsMap `HashMap.union` clsMap+      topEntities'                  =+        flip State.evalState tcMap' $ mapM (\(topEnt,annM,benchM) -> do+          topEnt' <- coreToName GHC.varName GHC.varUnique qualfiedNameString topEnt+          benchM' <- traverse (coreToName GHC.varName GHC.varUnique qualfiedNameString) benchM+          return (topEnt',annM,benchM')) topEntities+      retypedBindings               = retypeBindings allTcCache allBindings topEntities'+      topEntities''                 = map (\(topEnt,annM,benchM) -> case HashMap.lookup (nameOcc topEnt) retypedBindings of+                                              Just (_,ty,_,_,_) -> (topEnt,ty,annM,benchM)+                                              Nothing       -> error "This shouldn't happen"+                                          ) topEntities'++  return (retypedBindings,allTcCache,tupTcCache,topEntities'',primMap)++retypeBindings+  :: HashMap TyConOccName TyCon+  -> BindingMap+  -> [(TmName,Maybe TopEntity,Maybe TmName)]+  -> BindingMap+retypeBindings allTcCache = foldl' go+  where+    go allBindings (topEnt,_,benchM) = bBindings+      where+        topEntity = do e <- HashMap.lookup (nameOcc topEnt) allBindings+                       return (nameOcc topEnt,e)+        bench     = do t <- benchM+                       e <- HashMap.lookup (nameOcc t) allBindings+                       return (nameOcc t,e)++        tBindings = maybe allBindings (retype' allBindings) topEntity+        bBindings = maybe tBindings (retype' tBindings) bench+        retype' d (t,_) = snd (retype allTcCache ([],d) t)++-- | clean up cast-removal mess+retype+  :: HashMap TyConOccName TyCon+  -> ([TmOccName], BindingMap) -- (visited, bindings)+  -> TmOccName                 -- top+  -> ([TmOccName], BindingMap)+retype tcm (visited,bindings) current = (visited', HashMap.insert current (nm,ty',sp,inl,tm') bindings')+  where+    (nm,_,sp,inl,tm)     = bindings HashMap.! current+    used                 = Set.toList $ Lens.setOf termFreeIds tm+    (visited',bindings') = foldl (retype tcm) (current:visited,bindings) (filter (`notElem` visited) used)+    used'                = map ((^. _1) . (bindings' HashMap.!)) used+    usedTys              = map ((^. _2) . (bindings' HashMap.!)) used+    usedVars             = zipWith Var usedTys used'+    tm'                  = substTms (zip used usedVars) tm+    ty'                  = runFreshM (termType tcm tm')++mkBindings+  :: PrimMap a+  -> [GHC.CoreBind]+  -- Binders+  -> [(GHC.CoreBndr,Int)]+  -- Class operations+  -> [GHC.CoreBndr]+  -- Unlocatable Expressions+  -> State GHC2CoreState+           ( BindingMap+           , HashMap TmOccName (TmName,Type,Int)+           )+mkBindings primMap bindings clsOps unlocatable = do+  bindingsList <- mapM (\case+                          GHC.NonRec v e -> do+                            let sp = GHC.getSrcSpan v+                                inl = GHC.inlinePragmaSpec . GHC.inlinePragInfo $ GHC.idInfo v+                            tm <- coreToTerm primMap unlocatable sp e+                            v' <- coreToId v+                            return [(nameOcc (varName v'), (varName v',unembed (varType v'), sp, inl, tm))]+                          GHC.Rec bs -> do+                            tms <- mapM (\(v,e) -> do+                                          let sp = GHC.getSrcSpan v+                                          tm <- coreToTerm primMap unlocatable sp e+                                          v' <- coreToId v+                                          return (v',sp,tm)+                                        ) bs+                            case tms of+                              [(v,sp,tm)] -> return [(nameOcc (varName v), (varName v,unembed (varType v), sp, GHC.NoInline, tm))]+                              _ ->+                                return $ map (\(v,sp,e) -> (nameOcc (varName v),(varName v,unembed (varType v),sp,GHC.NoInline+                                                  ,Letrec (bind (rec (map (\(x,_,y) -> (x,embed y)) tms)) e)))) tms+                       ) bindings+  clsOpList    <- mapM (\(v,i) -> do+                          v' <- coreToId v+                          let ty = unembed $ varType v'+                          return (nameOcc (varName v'), (varName v',ty,i))+                       ) clsOps++  return (HashMap.fromList (concat bindingsList), HashMap.fromList clsOpList)++mkClassSelector+  :: HashMap TyConOccName TyCon+  -> Type+  -> Int+  -> Term+mkClassSelector tcm ty sel = newExpr+  where+    ((tvs,dictTy:_),_) = first (lefts *** rights)+                       $ first (span (\l -> case l of Left _ -> True+                                                      _      -> False))+                       $ splitFunForallTy ty+    newExpr = case tyView dictTy of+      (TyConApp _ _) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do+                          (dcId,dcVar) <- mkInternalVar (string2SystemName "dict") dictTy+                          selE         <- mkSelectorCase "mkClassSelector" tcm dcVar 1 sel+                          return (mkTyLams (mkLams selE [dcId]) tvs)+      (FunTy arg res) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do+                           (dcId,dcVar) <- mkInternalVar (string2SystemName "dict") (mkFunTy arg res)+                           return (mkTyLams (mkLams dcVar [dcId]) tvs)+      (OtherType oTy) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do+                           (dcId,dcVar) <- mkInternalVar (string2SystemName "dict") oTy+                           return (mkTyLams (mkLams dcVar [dcId]) tvs)++mkTupTyCons :: GHC2CoreState -> (GHC2CoreState,IntMap TyConName)+mkTupTyCons tcMap = (tcMap'',tupTcCache)+  where+    tupTyCons        = map (GHC.tupleTyCon GHC.Boxed) [2..62]+    (tcNames,tcMap') = State.runState (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique qualfiedNameString tc) tupTyCons) tcMap+    tupTcCache       = IM.fromList (zip [2..62] tcNames)+    tupHM            = HashMap.fromList (zip (map nameOcc tcNames) tupTyCons)+    tcMap''          = tcMap' & tyConMap %~ (`HashMap.union` tupHM)
+ src-ghc/Clash/GHC/LoadInterfaceFiles.hs view
@@ -0,0 +1,244 @@+{-|+  Copyright   :  (C) 2013-2016, University of Twente,+                     2016-2017, Myrtle Software Ltd+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TupleSections       #-}++module Clash.GHC.LoadInterfaceFiles+  (loadExternalExprs)+where++-- External Modules+import           Data.Either (partitionEithers)+import           Data.List   (elemIndex, foldl', partition)+import           Data.Maybe  (isJust, isNothing, mapMaybe)+import           Data.Word   (Word8)++import           Clash.Annotations.Primitive++-- GHC API+import qualified Annotations+import qualified BasicTypes+import qualified Class+import qualified CoreFVs+import qualified CoreSyn+import qualified Demand+import           DynFlags    (unsafeGlobalDynFlags)+import qualified GHC+import qualified Id+import qualified IdInfo+import qualified IfaceSyn+import qualified LoadIface+import qualified Maybes+import qualified MkCore+#if MIN_VERSION_ghc(8,2,0)+import qualified Module+#endif+import qualified MonadUtils+import qualified Name+import           Outputable  (showPpr, showSDoc, text)+#if MIN_VERSION_ghc(8,4,1)+import qualified GhcPlugins+#else+import qualified Serialized+#endif+import qualified TcIface+import qualified TcRnMonad+import qualified TcRnTypes+import qualified UniqFM+import qualified UniqSet+import qualified Var+#if !MIN_VERSION_ghc(8,2,0)+import qualified VarSet+#endif++-- Internal Modules+import           Clash.Util  ((***), curLoc, traceIf)++runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a+runIfl modName action = do+  hscEnv <- GHC.getSession+#if MIN_VERSION_ghc(8,2,0)+  let localEnv = TcRnTypes.IfLclEnv modName False (text "runIfl") Nothing+                   Nothing UniqFM.emptyUFM UniqFM.emptyUFM+#else+  let localEnv = TcRnTypes.IfLclEnv modName (text "runIfl")+                   UniqFM.emptyUFM UniqFM.emptyUFM+#endif+  let globalEnv = TcRnTypes.IfGblEnv (text "Clash.runIfl") Nothing+  MonadUtils.liftIO $ TcRnMonad.initTcRnIf 'r' hscEnv globalEnv+                        localEnv action++loadDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL GHC.TyThing+loadDecl = TcIface.tcIfaceDecl False++loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface)+loadIface foundMod = do+#if MIN_VERSION_ghc(8,2,0)+  ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface")+                  (fst (Module.splitModuleInsts foundMod)) foundMod False+#else+  ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface") foundMod False+#endif+  case ifaceFailM of+    Maybes.Succeeded (modInfo,_) -> return (Just modInfo)+    Maybes.Failed msg -> let msg' = concat [ $(curLoc)+                                           , "Failed to load interface for module: "+                                           , showPpr unsafeGlobalDynFlags foundMod+                                           , "\nReason: "+                                           , showSDoc unsafeGlobalDynFlags msg+                                           ]+                         in traceIf True msg' (return Nothing)++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+       , [FilePath]+       )+loadExternalExprs hdl = go [] [] [] []+  where+    go locatedExprs clsOps unlocated pFP _ [] =+      return (locatedExprs,clsOps,unlocated,pFP)++    go locatedExprs clsOps unlocated pFP visited (CoreSyn.NonRec _ e:bs) = do+      (locatedExprs',clsOps',unlocated',pFP',visited') <-+        go' locatedExprs clsOps unlocated pFP visited [e]+      go locatedExprs' clsOps' unlocated' pFP' visited' bs++    go locatedExprs clsOps unlocated pFP visited (CoreSyn.Rec bs:bs') = do+      (locatedExprs',clsOps',unlocated',pFP',visited') <-+        go' locatedExprs clsOps unlocated pFP visited (map snd bs)+      go locatedExprs' clsOps' unlocated' pFP' visited' bs'++    go' locatedExprs clsOps unlocated pFP visited [] =+      return (locatedExprs,clsOps,unlocated,pFP,visited)++    go' locatedExprs clsOps unlocated pFP visited (e:es) = do+      let fvs = CoreFVs.exprSomeFreeVarsList+                  (\v -> Var.isId v &&+                         isNothing (Id.isDataConId_maybe v) &&+                         not (v `UniqSet.elementOfUniqSet` visited)+                  ) e++          (clsOps',fvs') = partition (isJust . Id.isClassOpId_maybe) fvs++          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'++      ((locatedExprs',unlocated'),pFP') <-+         ((partitionEithers *** concat) . unzip) <$> mapM (loadExprFromIface hdl) fvs'++      let visited' = foldl' UniqSet.addListToUniqSet visited+                       [ map fst locatedExprs'+                       , unlocated'+                       , clsOps'+                       ]++      go' (locatedExprs'++locatedExprs)+          (clsOps''++clsOps)+          (unlocated'++unlocated)+          (pFP'++pFP)+          visited'+          (es ++ map snd locatedExprs')++loadExprFromIface ::+  GHC.GhcMonad m+  => HDL+  -> CoreSyn.CoreBndr+  -> m (Either+          (CoreSyn.CoreBndr,CoreSyn.CoreExpr)+          CoreSyn.CoreBndr+       ,[FilePath]+       )+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,[])+        Just iface -> do+          let decls = map snd (GHC.mi_decls iface)+          let nameFun = GHC.getOccName $ Var.varName bndr+#if MIN_VERSION_ghc(8,2,0)+          let declM = filter ((== nameFun) . Name.nameOccName . IfaceSyn.ifName) decls+#else+          let declM = filter ((== nameFun) . IfaceSyn.ifName) decls+#endif+          anns <- TcIface.tcIfaceAnnotations (GHC.mi_anns iface)+          let primFPs = loadPrimitiveAnnotations hdl anns+          case declM of+            [namedDecl] -> do+              tyThing <- loadDecl namedDecl+              return (loadExprFromTyThing bndr tyThing,primFPs)+            _ -> return (Right bndr,primFPs)+    Nothing -> return (Right bndr,[])++loadPrimitiveAnnotations+  :: HDL+  -> [Annotations.Annotation]+  -> [FilePath]+loadPrimitiveAnnotations hdl anns = mapMaybe toFP (concat prims)+  where+    annEnv       = Annotations.mkAnnEnv anns+    prims        = UniqFM.eltsUFM (Annotations.deserializeAnns deserializer annEnv)+#if MIN_VERSION_ghc(8,4,1)+    deserializer = GhcPlugins.deserializeWithData :: ([Word8] -> Primitive)+#else+    deserializer = Serialized.deserializeWithData :: ([Word8] -> Primitive)+#endif+    toFP (Primitive hdl' fp)+      | hdl == hdl'+      = Just fp+    toFP _ = Nothing++loadExprFromTyThing :: CoreSyn.CoreBndr+                    -> GHC.TyThing+                    -> Either+                         (CoreSyn.CoreBndr,CoreSyn.CoreExpr)  -- Located Binder+                         CoreSyn.CoreBndr                     -- unlocatable Var+loadExprFromTyThing bndr tyThing = case tyThing of+  GHC.AnId _id | Var.isId _id ->+    let _idInfo    = Var.idInfo _id+        unfolding  = IdInfo.unfoldingInfo _idInfo+        inlineInfo = IdInfo.inlinePragInfo _idInfo+    in case unfolding of+      (CoreSyn.CoreUnfolding {}) ->+        case (BasicTypes.inl_inline inlineInfo,BasicTypes.inl_act inlineInfo) of+          (BasicTypes.NoInline,BasicTypes.AlwaysActive) -> Right bndr+          (BasicTypes.NoInline,BasicTypes.NeverActive)  -> Right bndr+          (BasicTypes.NoInline,_) -> Left (bndr, CoreSyn.unfoldingTemplate unfolding)+          _ -> Left (bndr, CoreSyn.unfoldingTemplate unfolding)+      (CoreSyn.DFunUnfolding dfbndrs dc es) ->+        let dcApp  = MkCore.mkCoreConApps dc es+            dfExpr = MkCore.mkCoreLams dfbndrs dcApp+        in Left (bndr,dfExpr)+      CoreSyn.NoUnfolding+        | Demand.isBottomingSig $ IdInfo.strictnessInfo _idInfo+#if MIN_VERSION_ghc(8,2,2)+        -> Left (bndr, MkCore.mkAbsentErrorApp+#else+        -> Left (bndr, MkCore.mkRuntimeErrorApp MkCore.aBSENT_ERROR_ID+#endif+                                                (Var.varType _id)+                                                ("no_unfolding " ++ showPpr unsafeGlobalDynFlags bndr)+                )+      _ -> Right bndr+  _ -> Right bndr
+ src-ghc/Clash/GHC/LoadModules.hs view
@@ -0,0 +1,521 @@+{-|+  Copyright   :  (C) 2013-2016, University of Twente,+                     2016-2017, Myrtle Software Ltd,+                     2017     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE ViewPatterns        #-}++module Clash.GHC.LoadModules+  ( loadModules+  , ghcLibDir+  )+where++#ifndef TOOL_VERSION_ghc+#error TOOL_VERSION_ghc undefined+#endif++-- External Modules+import           Control.Arrow                (second)+import           Data.Generics.Uniplate.DataOnly (transform)+import           Data.List                    (foldl', lookup, nub)+import           Data.Maybe                   (listToMaybe)+import           Data.Word                    (Word8)+import           Clash.Annotations.Primitive  (HDL)+import           Clash.Annotations.TopEntity  (TopEntity (..))+import           System.Exit                  (ExitCode (..))+import           System.IO                    (hGetLine)+import           System.IO.Error              (tryIOError)+import           System.Process               (runInteractiveCommand,+                                               waitForProcess)++-- GHC API+import qualified Annotations+import qualified CoreSyn+import qualified CoreFVs+import qualified Digraph+import           DynFlags                     (GeneralFlag (..))+import qualified DynFlags+import qualified GHC+import qualified HscMain+import qualified HscTypes+import qualified MonadUtils+import qualified Panic+#if MIN_VERSION_ghc(8,4,1)+import qualified GhcPlugins+#else+import qualified Serialized+#endif+import qualified TidyPgm+import qualified TcRnMonad+import qualified TcRnTypes+import qualified Unique+#if MIN_VERSION_ghc(8,2,0)+import qualified UniqDFM+#else+import qualified UniqFM+#endif+import qualified UniqSet+import qualified Var+import qualified FamInst+import qualified FamInstEnv+import qualified Name+import           Outputable                   (ppr)+import qualified Outputable+import qualified OccName+import qualified GHC.LanguageExtensions       as LangExt++-- Internal Modules+import           Clash.GHC.GHC2Core           (modNameM)+import           Clash.GHC.LoadInterfaceFiles+import           Clash.Util                   (curLoc)++ghcLibDir :: IO FilePath+ghcLibDir = do+  (libDirM,exitCode) <- getProcessOutput $ "ghc-" ++ TOOL_VERSION_ghc ++ " --print-libdir"+  case exitCode of+     ExitSuccess   -> case libDirM of+       Just libDir -> return libDir+       Nothing     -> Panic.pgmError noGHC+     ExitFailure i -> case i of+       127         -> Panic.pgmError noGHC+       i'          -> Panic.pgmError $ "Calling GHC failed with error code: " ++ show i'+  where+    noGHC = "Clash needs the GHC compiler it was built with, ghc-" ++ TOOL_VERSION_ghc +++            ", but it was not found. Make sure its location is in your PATH variable."++getProcessOutput :: String -> IO (Maybe String, ExitCode)+getProcessOutput command =+     -- Create the process+  do (_, pOut, _, handle) <- runInteractiveCommand command+     -- Wait for the process to finish and store its exit code+     exitCode <- waitForProcess handle+     -- Get the standard output.+     output   <- either (const Nothing) Just <$> tryIOError (hGetLine pOut)+     -- return both the output and the exit code.+     return (output, exitCode)++loadModules+  :: HDL+  -> String+  -> Maybe (DynFlags.DynFlags)+  -> IO ( [CoreSyn.CoreBind]                     -- Binders+        , [(CoreSyn.CoreBndr,Int)]               -- Class operations+        , [CoreSyn.CoreBndr]                     -- Unlocatable Expressions+        , FamInstEnv.FamInstEnvs+        , [( CoreSyn.CoreBndr                    -- topEntity bndr+           , Maybe TopEntity                     -- (maybe) TopEntity annotation+           , Maybe CoreSyn.CoreBndr)]            -- (maybe) testBench bndr+        , [FilePath]+        )+loadModules hdl modName dflagsM = do+  libDir <- MonadUtils.liftIO ghcLibDir++  GHC.runGhc (Just libDir) $ do+    dflags <- case dflagsM of+                Just df -> return df+                Nothing -> do+                  df <- GHC.getSessionDynFlags+                  let dfEn = foldl DynFlags.xopt_set df+                                [ LangExt.TemplateHaskell+                                , LangExt.TemplateHaskellQuotes+                                , LangExt.DataKinds+                                , LangExt.MonoLocalBinds+                                , LangExt.TypeOperators+                                , LangExt.FlexibleContexts+                                , LangExt.ConstraintKinds+                                , LangExt.TypeFamilies+                                , LangExt.BinaryLiterals+                                , LangExt.ExplicitNamespaces+                                , LangExt.KindSignatures+                                , LangExt.DeriveLift+                                , LangExt.TypeApplications+                                , LangExt.ScopedTypeVariables+                                , LangExt.MagicHash+                                , LangExt.ExplicitForAll+                                ]+                  let dfDis = foldl DynFlags.xopt_unset dfEn+                                [ LangExt.ImplicitPrelude+                                , LangExt.MonomorphismRestriction+                                , LangExt.Strict+                                , LangExt.StrictData+                                ]+                  let ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"+                      ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"+                      ghcTyLitKNPlugin   = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"+                  let dfPlug = dfDis { DynFlags.pluginModNames = nub $+                                          ghcTyLitNormPlugin : ghcTyLitExtrPlugin :+                                          ghcTyLitKNPlugin : DynFlags.pluginModNames dfDis+                                     }+                  return dfPlug++    let dflags1 = dflags+#if __GLASGOW_HASKELL__ >= 711+                    { DynFlags.reductionDepth = 1000+#else+                    { DynFlags.ctxtStkDepth = 1000+#endif+                    , DynFlags.optLevel = 2+                    , DynFlags.ghcMode  = GHC.CompManager+                    , DynFlags.ghcLink  = GHC.LinkInMemory+                    , DynFlags.hscTarget = DynFlags.defaultObjectTarget+                                             (DynFlags.targetPlatform dflags)+                    }+    let dflags2 = wantedOptimizationFlags 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+    _ <- GHC.setSessionDynFlags dflags3+    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 { pMod  <- parseModule m+                                 ; 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+                                 ; (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+                                 ; return (pgm,modFamInstEnv)+                                 }+                         ) modGraph2++    let (binders,modFamInstEnvs) = unzip tidiedMods+        bindersC                 = concat binders+        binderIds                = map fst (CoreSyn.flattenBinds bindersC)+#if MIN_VERSION_ghc(8,2,0)+        modFamInstEnvs'          = foldr UniqDFM.plusUDFM UniqDFM.emptyUDFM modFamInstEnvs+#else+        modFamInstEnvs'          = foldr UniqFM.plusUFM UniqFM.emptyUFM modFamInstEnvs+#endif++    (externalBndrs,clsOps,unlocatable,pFP) <-+      loadExternalExprs hdl (UniqSet.mkUniqSet binderIds) bindersC++    hscEnv <- GHC.getSession+    famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs++    -- 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   <- findSynthesizeAnnotations binderIds+    benchAnn <- findTestBenchAnnotations binderIds+    topSyn   <- findSynthesizeAnnotations rootIds+    let varNameString = OccName.occNameString . Name.nameOccName . Var.varName+        topEntities = filter ((== "topEntity") . varNameString) rootIds+        benches     = filter ((== "testBench") . varNameString) rootIds+        mergeBench (x,y) = (x,y,lookup x benchAnn)+        allSyn'     = map mergeBench allSyn+    topEntities' <- case topEntities of+      [] -> case topSyn of+        [] -> Panic.pgmError $ "No 'topEntity', nor function with a 'Synthesize' annotation found in root module: " +++                                (Outputable.showSDocUnsafe (ppr rootModule))+        _ -> return allSyn'+      [x] -> case lookup x topSyn of+        Nothing -> case lookup x benchAnn of+          Nothing -> return ((x,Nothing,listToMaybe benches):allSyn')+          Just y  -> return ((x,Nothing,Just y):allSyn')+        Just _  -> return allSyn'+      _ -> Panic.pgmError $ $(curLoc) ++ "Multiple 'topEntities' found."++    return (bindersC ++ makeRecursiveGroups externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntities',nub pFP)++-- | Given a set of bindings, make explicit non-recursive bindings and+-- recursive binding groups.+--+-- Needed because:+-- 1. GHC does not preserve this information in interface files,+-- 2. Binders in Clash's BindingsMap are not allowed to be mutually recursive,+--    only self-recursive.+-- 3. Clash.GHC.GenerateBindings.mkBindings turns groups of mutually recursive+--    bindings into self-recursive bindings which can go into the BindingsMap.+makeRecursiveGroups+  :: [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)]+  -> [CoreSyn.CoreBind]+makeRecursiveGroups+  = map makeBind+  . Digraph.stronglyConnCompFromEdgedVerticesUniq+  . map makeNode+  where+    makeNode+      :: (CoreSyn.CoreBndr,CoreSyn.CoreExpr)+      -> Digraph.Node Unique.Unique (CoreSyn.CoreBndr,CoreSyn.CoreExpr)+    makeNode (b,e) =+#if MIN_VERSION_ghc(8,4,1)+      Digraph.DigraphNode+        (b,e)+        (Var.varUnique b)+        (UniqSet.nonDetKeysUniqSet (CoreFVs.exprFreeIds e))+#else+      ((b,e)+      ,Var.varUnique b+      ,UniqSet.nonDetKeysUniqSet (CoreFVs.exprFreeIds e))+#endif++    makeBind+      :: Digraph.SCC (CoreSyn.CoreBndr,CoreSyn.CoreExpr)+      -> CoreSyn.CoreBind+    makeBind (Digraph.AcyclicSCC (b,e)) = CoreSyn.NonRec b e+    makeBind (Digraph.CyclicSCC bs)     = CoreSyn.Rec bs++findSynthesizeAnnotations+  :: GHC.GhcMonad m+  => [CoreSyn.CoreBndr]+  -> m [(CoreSyn.CoreBndr,Maybe TopEntity)]+findSynthesizeAnnotations bndrs = do+#if MIN_VERSION_ghc(8,4,1)+  let deserializer = GhcPlugins.deserializeWithData :: ([Word8] -> TopEntity)+#else+  let deserializer = Serialized.deserializeWithData :: ([Word8] -> TopEntity)+#endif+      targets      = map (Annotations.NamedTarget . Var.varName) bndrs++  anns <- mapM (GHC.findGlobalAnns deserializer) targets+  let isSyn (Synthesize {}) = True+      isSyn _               = False+      anns'    = map (filter isSyn) anns+      annBndrs = filter (not . null . snd) (zip bndrs anns')+  case filter ((> 1) . length . snd) annBndrs of+    [] -> return (map (second listToMaybe) annBndrs)+    as -> Panic.pgmError $+            "The following functions have multiple 'Synthesize' annotations: " +++            Outputable.showSDocUnsafe (ppr (map fst as))++findTestBenchAnnotations+  :: GHC.GhcMonad m+  => [CoreSyn.CoreBndr]+  -> m [(CoreSyn.CoreBndr,CoreSyn.CoreBndr)]+findTestBenchAnnotations bndrs = do+#if MIN_VERSION_ghc(8,4,1)+  let deserializer = GhcPlugins.deserializeWithData :: ([Word8] -> TopEntity)+#else+  let deserializer = Serialized.deserializeWithData :: ([Word8] -> TopEntity)+#endif+      targets      = map (Annotations.NamedTarget . Var.varName) bndrs++  anns <- mapM (GHC.findGlobalAnns deserializer) targets+  let isTB (TestBench {}) = True+      isTB _              = False+      anns'     = map (filter isTB) anns+      annBndrs  = filter (not . null . snd) (zip bndrs anns')+      annBndrs' = case filter ((> 1) . length . snd) annBndrs of+        [] -> map (second head) annBndrs+        as -> Panic.pgmError $+          "The following functions have multiple 'TestBench' annotations: " +++          Outputable.showSDocUnsafe (ppr (map fst as))+  return (map (second findTB) annBndrs')+  where+    findTB :: TopEntity -> CoreSyn.CoreBndr+    findTB (TestBench tb) = case listToMaybe (filter (eqNm tb) bndrs) of+      Just tb' -> tb'+      Nothing  -> Panic.pgmError $+        "TestBench named: " ++ show tb ++ " not found"+    findTB _ = Panic.pgmError "Unexpected Synthesize"++    eqNm thNm bndr = show thNm == qualNm+      where+        bndrNm  = Var.varName bndr+        qualNm  = maybe occName (\modName -> modName ++ ('.':occName)) (modNameM bndrNm)+        occName = OccName.occNameString (Name.nameOccName bndrNm)++parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule+parseModule modSum = do+  (GHC.ParsedModule pmModSum pmParsedSource extraSrc anns) <-+    GHC.parseModule modSum+  return (GHC.ParsedModule+            (disableOptimizationsFlags pmModSum)+            pmParsedSource extraSrc anns)++disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary+disableOptimizationsFlags ms@(GHC.ModSummary {..})+  = ms {GHC.ms_hspp_opts = dflags}+  where+    dflags = wantedOptimizationFlags (ms_hspp_opts+              { DynFlags.optLevel = 2+#if __GLASGOW_HASKELL__ >= 711+              , DynFlags.reductionDepth = 1000+#else+              , DynFlags.ctxtStkDepth = 1000+#endif+              })++wantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags+wantedOptimizationFlags df =+  foldl' DynFlags.xopt_unset+    (foldl' DynFlags.gopt_unset+        (foldl' DynFlags.gopt_set df wanted) unwanted) unwantedLang+  where+    wanted = [ Opt_CSE -- CSE+             , Opt_Specialise -- Specialise on types, specialise type-class-overloaded function defined in this module for the types+             , Opt_DoLambdaEtaExpansion -- transform nested series of lambdas into one with multiple arguments, helps us achieve only top-level lambdas+             , Opt_CaseMerge -- We want fewer case-statements+             , Opt_DictsCheap -- Makes dictionaries seem cheap to optimizer: hopefully inline+             , Opt_ExposeAllUnfoldings -- We need all the unfoldings we can get+             , Opt_ForceRecomp -- Force recompilation: never bad+             , Opt_EnableRewriteRules -- Reduce number of functions+             , Opt_SimplPreInlining -- Inlines simple functions, we only care about the major first-order structure+             , Opt_StaticArgumentTransformation -- Turn on the static argument transformation, which turns a recursive function into a non-recursive one with a local recursive loop.+             , Opt_FloatIn -- Moves let-bindings inwards, although it defeats the normal-form with a single top-level let-binding, it helps with other transformations+             , Opt_DictsStrict -- Hopefully helps remove class method selectors+             , Opt_DmdTxDictSel -- I think demand and strictness are related, strictness helps with dead-code, enable+             , Opt_Strictness -- Strictness analysis helps with dead-code analysis. However, see [NOTE: CPR breaks Clash]+             , Opt_SpecialiseAggressively -- Needed to compile Fixed point number functions quickly+             , Opt_CrossModuleSpecialise -- Needed to compile Fixed point number functions quickly+             ]++    unwanted = [ Opt_LiberateCase -- Perform unrolling of recursive RHS: avoid+               , Opt_SpecConstr -- Creates local-functions: avoid+               , Opt_IgnoreAsserts -- We don't care about assertions+               , Opt_DoEtaReduction -- We want eta-expansion+               , Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid+               , Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid+               , Opt_Vectorise -- Don't care+               , Opt_VectorisationAvoidance -- Don't care+               , Opt_RegsGraph -- Don't care+               , Opt_RegsGraph -- Don't care+               , Opt_PedanticBottoms -- Stops eta-expansion through case: avoid+               , Opt_LlvmTBAA -- Don't care+               , Opt_CmmSink -- Don't care+               , Opt_CmmElimCommonBlocks -- Don't care+               , Opt_OmitYields -- Don't care+               , Opt_IgnoreInterfacePragmas -- We need all the unfoldings we can get+               , Opt_OmitInterfacePragmas -- We need all the unfoldings we can get+               , Opt_IrrefutableTuples -- Introduce irrefutPatError: avoid+               , Opt_Loopification -- STG pass, don't care+               , Opt_CprAnal -- The worker/wrapper introduced by CPR breaks Clash, see [NOTE: CPR breaks Clash]+               , Opt_FullLaziness -- increases sharing, but seems to result in worse circuits (in both area and propagation delay)+               ]++    -- Coercions between Integer and Clash' numeric primitives cause Clash to+    -- fail. As strictness only affects simulation behaviour, removing them+    -- is perfectly safe.+    unwantedLang = [ LangExt.Strict+                   , LangExt.StrictData+                   ]++-- [NOTE: CPR breaks Clash]+-- We used to completely disable strictness analysis because it causes GHC to+-- do the so-called "Constructed Product Result" (CPR) analysis, which in turn+-- creates an annoying worker/wrapper which does the following:+--+--   * Scrutinise a Signal, and pack the head and tail of the+--     Signal in an unboxed tuple.+--   * Scrutinise on the unboxed tuple, and recreate the Signal.+--+-- This is problematic because the 'Signal' type is essentially treated as a "transparent"+-- type by the Clash compiler, so observing its constructor leads to all kinds+-- of problems.+--+-- The current solution is to disable strictness analysis in "Clash.Signal.Internal"+-- so that functions manipulating 'Signal' constructor do not get a strictness/+-- demand/CPR annotation, which in turn ensures GHC doesn't create worker/wrappers+-- for when these functions are called in user code.+--+-- Ultimately we should stop treating Signal as a "transparent" type and deal+-- handling of the Signal type, and the involved co-recursive functions,+-- properly. At the moment, Clash cannot deal with this recursive type and the+-- recursive functions involved, and hence we need to disable this useful transformation. After+-- everything is done properly, we should enable it again.++-- | Remove all strictness annotations:+--+-- * Remove strictness annotations from data type declarations+--   (only works for data types that are currently being compiled, i.e.,+--    that are not part of a pre-compiled imported library)+--+-- We need to remove strictness annotations because GHC will introduce casts+-- between Integer and Clash' numeric primitives otherwise, where Clash will+-- error when it sees such casts. The reason it does this is because+-- Integer is a completely unconstrained integer type and is currently+-- (erroneously) translated to a 64-bit integer in the HDL; this means that+-- we could lose bits when the original numeric type had more bits than 64.+--+-- Removing these strictness annotations is perfectly safe, as they only+-- affect simulation behaviour.+removeStrictnessAnnotations ::+     GHC.ParsedModule+  -> GHC.ParsedModule+removeStrictnessAnnotations pm =+    pm {GHC.pm_parsed_source = fmap rmPS (GHC.pm_parsed_source pm)}+  where+    rmPS :: GHC.DataId name => GHC.HsModule name -> GHC.HsModule name+    rmPS hsm = hsm {GHC.hsmodDecls = (fmap . fmap) rmHSD (GHC.hsmodDecls hsm)}++    rmHSD :: GHC.DataId name => GHC.HsDecl name -> GHC.HsDecl name+    rmHSD (GHC.TyClD tyClDecl) = GHC.TyClD (rmTyClD tyClDecl)+    rmHSD hsd = hsd++    rmTyClD :: GHC.DataId name => GHC.TyClDecl name -> GHC.TyClDecl name+    rmTyClD dc@(GHC.DataDecl {}) = dc {GHC.tcdDataDefn = rmDataDefn (GHC.tcdDataDefn dc)}+    rmTyClD tyClD = tyClD++    rmDataDefn :: GHC.DataId name => GHC.HsDataDefn name -> GHC.HsDataDefn name+    rmDataDefn hdf = hdf {GHC.dd_cons = (fmap . fmap) rmCD (GHC.dd_cons hdf)}++    rmCD :: GHC.DataId name => GHC.ConDecl name -> GHC.ConDecl name+    rmCD gadt@(GHC.ConDeclGADT {}) = gadt {GHC.con_type = rmSigType (GHC.con_type gadt)}+    rmCD h98@(GHC.ConDeclH98 {})   = h98  {GHC.con_details = rmConDetails (GHC.con_details h98)}++    -- type LHsSigType name = HsImplicitBndrs name (LHsType name)+    rmSigType :: GHC.DataId name => GHC.LHsSigType name -> GHC.LHsSigType name+    rmSigType hsIB = hsIB {GHC.hsib_body = rmHsType (GHC.hsib_body hsIB)}++    -- type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name])+    rmConDetails :: GHC.DataId name => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name+    rmConDetails (GHC.PrefixCon args) = GHC.PrefixCon (fmap rmHsType args)+    rmConDetails (GHC.RecCon rec)     = GHC.RecCon ((fmap . fmap . fmap) rmConDeclF rec)+    rmConDetails (GHC.InfixCon l r)   = GHC.InfixCon (rmHsType l) (rmHsType r)++    rmHsType :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name)+    rmHsType = transform go+      where+        go (GHC.unLoc -> GHC.HsBangTy _ ty) = ty+        go ty = ty++    rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name+    rmConDeclF cdf = cdf {GHC.cd_fld_type = rmHsType (GHC.cd_fld_type cdf)}
+ src-ghc/Clash/GHC/NetlistTypes.hs view
@@ -0,0 +1,199 @@+{-|+  Copyright   :  (C) 2013-2016, University of Twente,+                     2016-2017, Myrtle Software Ltd+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE ViewPatterns      #-}++module Clash.GHC.NetlistTypes+  (ghcTypeToHWType)+where++import Data.Coerce                      (coerce)+import Data.Functor.Identity            (Identity (..))+import Data.HashMap.Strict              (HashMap,(!))+import Data.Text.Lazy                   (pack)+import Control.Monad.Trans.Except+  (ExceptT (..), mapExceptT, runExceptT, throwE)++import Clash.Core.DataCon               (DataCon (..))+import Clash.Core.Name                  (Name (..), name2String)+import Clash.Core.Pretty                (showDoc)+import Clash.Core.TyCon                 (TyCon (..), TyConOccName, tyConDataCons)+import Clash.Core.Type+  (LitTy (..), Type (..), TypeView (..), coreView, tyView)+import Clash.Core.Util                  (tyNatSize)+import Clash.Netlist.Util               (coreTypeToHWType)+import Clash.Netlist.Types              (HWType(..))+import Clash.Signal.Internal            (ClockKind (..), ResetKind (..))+import Clash.Util                       (curLoc)++ghcTypeToHWType+  :: Int+  -> Bool+  -> HashMap TyConOccName TyCon+  -> Bool+  -> Type+  -> Maybe (Either String HWType)+ghcTypeToHWType iw floatSupport = go+  where+    go m keepVoid ty@(tyView -> TyConApp tc args) = runExceptT $+      case name2String tc of+        "GHC.Int.Int8"                  -> return (Signed 8)+        "GHC.Int.Int16"                 -> return (Signed 16)+        "GHC.Int.Int32"                 -> return (Signed 32)+        "GHC.Int.Int64"                 ->+          if iw < 64+             then case tyConDataCons (m ! nameOcc tc) of+                    [dc] -> case dcArgTys dc of+                      [tyView -> TyConApp nm _]+                        | name2String nm == "GHC.Prim.Int#"   ->+                            throwE $ unlines ["Int64 not supported in forced 32-bit mode on a 64-bit machine."+                                             ,"Run Clash with `-fclash-intwidth=64`."+                                             ]+                        | name2String nm == "GHC.Prim.Int64#" ->+                            return (Signed 64)+                      _  -> throwE $ $(curLoc) ++ "Int64 DC has unexpected amount of arguments"+                    _    -> throwE $ $(curLoc) ++ "Int64 TC has unexpected amount of DCs"+             else return (Signed 64)+        "GHC.Word.Word8"                -> return (Unsigned 8)+        "GHC.Word.Word16"               -> return (Unsigned 16)+        "GHC.Word.Word32"               -> return (Unsigned 32)+        "GHC.Word.Word64"               ->+          if iw < 64+             then case tyConDataCons (m ! nameOcc tc) of+                    [dc] -> case dcArgTys dc of+                      [tyView -> TyConApp nm _]+                        | name2String nm == "GHC.Prim.Word#"   ->+                            throwE $ unlines ["Word64 not supported in forced 32-bit mode on a 64-bit machine."+                                             ,"Run Clash with `-fclash-intwidth=64`."+                                             ]+                        | name2String nm == "GHC.Prim.Word64#" ->+                            return (Unsigned 64)+                      _  -> throwE $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments"+                    _    -> throwE $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs"+             else return (Unsigned 64)+        "GHC.Integer.Type.Integer"      -> return (Signed iw)+        "GHC.Natural.Natural"           -> return (Unsigned iw)+        "GHC.Prim.Char#"                -> return (Unsigned 21)+        "GHC.Prim.Int#"                 -> return (Signed iw)+        "GHC.Prim.Word#"                -> return (Unsigned iw)+        "GHC.Prim.Int64#"               -> return (Signed 64)+        "GHC.Prim.Word64#"              -> return (Unsigned 64)+        "GHC.Prim.Float#" | floatSupport -> return (BitVector 32)+        "GHC.Prim.Double#" | floatSupport -> return (BitVector 64)+        "GHC.Prim.ByteArray#"           ->+          throwE $ "Can't translate type: " ++ showDoc ty++        "GHC.Types.Bool"                -> return Bool+        "GHC.Types.Float" | floatSupport-> return (BitVector 32)+        "GHC.Types.Double" | floatSupport -> return (BitVector 64)+        "GHC.Prim.~#"                   -> return (Void Nothing)++        "GHC.Prim.Any" -> return (Void Nothing)++        "Clash.Signal.Internal.Signal" ->+          ExceptT $ return $ coreTypeToHWType go m keepVoid (args !! 1)++        "Clash.Signal.Internal.Clock"+          | [dom,clkKind] <- args+          -> do (nm,rate) <- domain m dom+                gated     <- clockKind m clkKind+                return (Clock (pack nm) rate gated)++        "Clash.Signal.Internal.Reset"+          | [dom,rstKind] <- args+          -> do (nm,rate)   <- domain m dom+                synchronous <- resetKind m rstKind+                return (Reset (pack nm) rate synchronous)++        "Clash.Sized.Internal.BitVector.Bit" -> return Bit++        "Clash.Sized.Internal.BitVector.BitVector" -> do+          n <- mapExceptT (Just . coerce) (tyNatSize m (head args))+          case n of+            0 -> return (Void (Just (BitVector (fromInteger n))))+            _ -> return (BitVector (fromInteger n))++        "Clash.Sized.Internal.Index.Index" -> do+          n <- mapExceptT (Just . coerce) (tyNatSize m (head args))+          if n < 2+             then return (Void (Just (Index (fromInteger n))))+             else return (Index (fromInteger n))++        "Clash.Sized.Internal.Signed.Signed" -> do+          n <- mapExceptT (Just . coerce) (tyNatSize m (head args))+          if n == 0+             then return (Void (Just (Signed (fromInteger n))))+             else return (Signed (fromInteger n))++        "Clash.Sized.Internal.Unsigned.Unsigned" -> do+          n <- mapExceptT (Just .coerce) (tyNatSize m (head args))+          if n == 0+             then return (Void (Just (Unsigned (fromInteger n))))+             else return (Unsigned (fromInteger n))++        "Clash.Sized.Vector.Vec" -> do+          let [szTy,elTy] = args+          sz     <- mapExceptT (Just . coerce) (tyNatSize m szTy)+          elHWTy <- ExceptT $ return $ coreTypeToHWType go m keepVoid elTy+          case elHWTy of+            Void {}     -> return (Void (Just (Vector (fromInteger sz) elHWTy)))+            _ | sz == 0 -> return (Void (Just (Vector (fromInteger sz) elHWTy)))+            _           -> return $ Vector (fromInteger sz) elHWTy++        "Clash.Sized.RTree.RTree" -> do+          let [szTy,elTy] = args+          sz     <- mapExceptT (Just . coerce) (tyNatSize m szTy)+          elHWTy <- ExceptT $ return $ coreTypeToHWType go m keepVoid elTy+          case elHWTy of+            Void {} -> return (Void (Just (RTree (fromInteger sz) elHWTy)))+            _       -> return $ RTree (fromInteger sz) elHWTy++        "String" -> return String+        "GHC.Types.[]" -> case tyView (head args) of+          (TyConApp (name2String -> "GHC.Types.Char") []) -> return String+          _ -> throwE $ "Can't translate type: " ++ showDoc ty++        _ -> ExceptT Nothing++    go _ _ _ = Nothing++domain+  :: HashMap TyConOccName TyCon+  -> Type+  -> ExceptT String Maybe (String,Integer)+domain m (coreView m -> Just ty') = domain m ty'+domain m (tyView -> TyConApp tcNm [LitTy (SymTy nm),rateTy])+  | name2String tcNm == "Clash.Signal.Internal.Dom"+  = do rate <- mapExceptT (Just . coerce) (tyNatSize m rateTy)+       return (nm,rate)+domain _ ty = throwE $ "Can't translate domain: " ++ showDoc ty++clockKind+  :: HashMap TyConOccName TyCon+  -> Type+  -> ExceptT String Maybe ClockKind+clockKind m (coreView m -> Just ty') = clockKind m ty'+clockKind _ (tyView -> TyConApp tcNm [])+  | name2String tcNm == "Clash.Signal.Internal.Source"+  = return Source+  | name2String tcNm == "Clash.Signal.Internal.Gated"+  = return Gated+clockKind _ ty = throwE $ "Can't translate ClockKind" ++ showDoc ty++resetKind+  :: HashMap TyConOccName TyCon+  -> Type+  -> ExceptT String Maybe ResetKind+resetKind m (coreView m -> Just ty') = resetKind m ty'+resetKind _ (tyView -> TyConApp tcNm [])+  | name2String tcNm == "Clash.Signal.Internal.Synchronous"+  = return Synchronous+  | name2String tcNm == "Clash.Signal.Internal.Asynchronous"+  = return Asynchronous+resetKind _ ty = throwE $ "Can't translate ResetKind" ++ showDoc ty
src-ghc/Interactive.hs view
@@ -10,7 +10,7 @@   ) where  import           System.Environment ( getArgs )-import           CLaSH.Main         ( defaultMain )+import           Clash.Main         ( defaultMain )  main :: IO () main = getArgs >>= defaultMain . ("--interactive":)