clash-ghc 1.0.1 → 1.2.0

raw patch · 37 files changed

+1224/−7176 lines, 37 filesdep +splitdep ~clash-libdep ~clash-preludedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: split

Dependency ranges changed: clash-lib, clash-prelude, ghc, ghc-boot, ghc-typelits-extra, ghci, haskeline, lens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +254/−460
• clash-ghc.cabal +50/−39
• src-bin-821/Clash/GHCi/HsVersions.h +0/−68
• src-bin-821/Clash/GHCi/UI.hs +0/−3893
• src-bin-821/Clash/GHCi/UI/Info.hs +0/−366
• src-bin-821/Clash/GHCi/UI/Monad.hs +0/−454
• src-bin-821/Clash/GHCi/UI/Tags.hs +0/−215
• src-bin-821/Clash/Main.hs +0/−1016
• src-bin-841/Clash/GHCi/UI.hs +25/−21
• src-bin-841/Clash/GHCi/UI/Info.hs +4/−4
• src-bin-841/Clash/GHCi/UI/Monad.hs +6/−1
• src-bin-841/Clash/GHCi/UI/Tags.hs +1/−0
• src-bin-841/Clash/Main.hs +14/−9
• src-bin-861/Clash/GHCi/Leak.hs +3/−1
• src-bin-861/Clash/GHCi/UI.hs +25/−21
• src-bin-861/Clash/GHCi/UI/Info.hs +4/−4
• src-bin-861/Clash/GHCi/UI/Monad.hs +6/−1
• src-bin-861/Clash/GHCi/UI/Tags.hs +1/−0
• src-bin-861/Clash/Main.hs +14/−9
• src-bin-881/Clash/GHCi/Leak.hs +3/−1
• src-bin-881/Clash/GHCi/UI.hs +27/−23
• src-bin-881/Clash/GHCi/UI/Info.hs +4/−5
• src-bin-881/Clash/GHCi/UI/Monad.hs +4/−1
• src-bin-881/Clash/GHCi/UI/Tags.hs +1/−0
• src-bin-881/Clash/GHCi/Util.hs +2/−1
• src-bin-881/Clash/Main.hs +14/−10
• src-bin-common/Clash/GHCi/Common.hs +14/−1
• src-ghc/Batch.hs +1/−0
• src-ghc/Clash/GHC/ClashFlags.hs +36/−17
• src-ghc/Clash/GHC/Evaluator.hs +423/−332
• src-ghc/Clash/GHC/GHC2Core.hs +139/−66
• src-ghc/Clash/GHC/GenerateBindings.hs +29/−27
• src-ghc/Clash/GHC/LoadInterfaceFiles.hs +5/−8
• src-ghc/Clash/GHC/LoadModules.hs +53/−77
• src-ghc/Clash/GHC/NetlistTypes.hs +39/−16
• src-ghc/Clash/GHC/Util.hs +22/−9
• src-ghc/Interactive.hs +1/−0

@@ -1,36 +1,155 @@-# Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package+# Changelog for the Clash project -## 1.0.1+## 1.2.0 *March 5th 2020*+As promised when releasing 1.0, we've tried our best to keep the API stable. We+think most designs will continue to compile with this new version, although special+care needs to be taken when using:++  * Use inline blackboxes. Instead of taking a single HDL, inline primitives now+    take multiple. For example, `InlinePrimitive VHDL ".."` must now be written+    as `InlinePrimitive [VHDL] ".."`.++  * Use the `Enum` instance for `BitVector`, `Index`, `Signed`, or `Unsigned`, as+    they now respect their `maxBound`. See [#1089](https://github.com/clash-lang/clash-compiler/issues/1089).++On top of that, we've added a number of new features:++  * `makeTopEntity`: Template Haskell function for generating TopEntity annotations. See [the documentation on Haddock](http://hackage.haskell.org/package/clash-prelude-1.2.0/docs/Clash-Annotations-TopEntity.html) for more information.++  * `Clash.Explicit.SimIO`: ((System)Verilog only) I/O actions that can be translated to HDL I/O. See [the documentation on Haddock](http://hackage.haskell.org/package/clash-prelude-1.2.0/docs/Clash-Explicit-SimIO.html) for more information.++  * `Clash.Class.AutoReg`: A smart register that improves the chances of synthesis tools inferring clock-gated registers, when used. See [the documentation on Haddock](http://hackage.haskell.org/package/clash-prelude-1.2.0/docs/Clash-Class-AutoReg.html) for more information.++The full list of changes follows. Happy hacking!++* New features (API):+  * `Clash.Class.Parity` type class replaces Prelude `odd` and `even` functions due to assumptions that don't hold for Clash specific numerical types, see [#970](https://github.com/clash-lang/clash-compiler/pull/970).+  * `NFDataX.ensureSpine`, see [#748](https://github.com/clash-lang/clash-compiler/pull/803)+  * `makeTopEntity` Template Haskell function for generating TopEntity annotations+    intended to cover the majority of use cases. Generation failures should either+    result in an explicit error, or a valid annotation of an empty `PortProduct`.+    Any discrepancy between the _shape_ of generated annotations and the _shape_+    of the Clash compiler is a bug. See [#795](https://github.com/clash-lang/clash-compiler/pull/795).+    Known limitations:+    * Type application (excluding `Signal`s and `:::`) is best effort:+    * Data types with type parameters will work if the generator can discover a single relevant constructor after attempting type application.+    * Arbitrary explicit clock/reset/enables are supported, but only a single `HiddenClockResetEnable` constraint is supported.+    * Data/type family support is best effort.+  * Added `Bundle ((f :*: g) a)` instance+  * Added `NFDataX CUShort` instance+  * Clash's internal type family solver now recognizes `AppendSymbol` and `CmpSymbol`+  * Added `Clash.Magic.suffixNameFromNat`: can be used in cases where `suffixName` is too slow+  * Added `Clash.Class.AutoReg`. Improves the chances of synthesis tools inferring clock-gated registers, when used. See [#873](https://github.com/clash-lang/clash-compiler/pull/873).+  * `Clash.Magic.suffixNameP`, `Clash.Magic.suffixNameFromNatP`: enable prefixing of name suffixes+  * Added `Clash.Magic.noDeDup`: can be used to instruct Clash to /not/ share a function between multiple branches+  * A `BitPack a` constraint now implies a `KnownNat (BitSize a)` constraint, so you won't have to add it manually anymore. See [#942](https://github.com/clash-lang/clash-compiler/pull/942).+  * `Clash.Explicit.SimIO`: ((System)Verilog only) I/O actions that can be translated to HDL I/O; useful for generated test benches.+  * Export `Clash.Explicit.Testbench.assertBitVector` [#888](https://github.com/clash-lang/clash-compiler/pull/888/files)+  * Add `Clash.Prelude.Testbench.assertBitVector` to achieve feature parity with `Clash.Explicit.Testbench`. [#891](https://github.com/clash-lang/clash-compiler/pull/891/files)+  * Add `Clash.XException.NFDataX.ensureSpine` [#803](https://github.com/clash-lang/clash-compiler/pull/803)+  * Add `Clash.Class.BitPack.bitCoerceMap` [#798](https://github.com/clash-lang/clash-compiler/pull/798)+  * Add `Clash.Magic.deDup`: instruct Clash to force sharing an operator between multiple branches of a case-expression+  * `InlinePrimitive` can now support multiple backends simultaneously [#425](https://github.com/clash-lang/clash-compiler/issues/425)+  * Add `Clash.XException.hwSeqX`: render declarations of an argument, but don't assign it to a result signal+  * Add `Clash.Signal.Bundle.TaggedEmptyTuple`: allows users to emulate the pre-1.0 behavior of "Bundle ()". See [#1100](https://github.com/clash-lang/clash-compiler/pull/1100)++* New features (Compiler):+  * [#961](https://github.com/clash-lang/clash-compiler/pull/961): Show `-fclash-*` Options in `clash --show-options`++* New internal features:+  * [#918](https://github.com/clash-lang/clash-compiler/pull/935): Add X-Optimization to normalization passes (-fclash-aggressive-x-optimization)+  * [#821](https://github.com/clash-lang/clash-compiler/pull/821): Add `DebugTry`: print name of all tried transformations, even if they didn't succeed+  * [#856](https://github.com/clash-lang/clash-compiler/pull/856): Add `-fclash-debug-transformations`: only print debug info for specific transformations+  * [#911](https://github.com/clash-lang/clash-compiler/pull/911): Add 'RenderVoid' option to blackboxes+  * [#958](https://github.com/clash-lang/clash-compiler/pull/958): Prefix names of inlined functions+  * [#947](https://github.com/clash-lang/clash-compiler/pull/947): Add "Clash.Core.TermLiteral"+  * [#887](https://github.com/clash-lang/clash-compiler/pull/887): Show nicer error messages when failing in TH code+  * [#884](https://github.com/clash-lang/clash-compiler/pull/884): Teach reduceTypeFamily about AppendSymbol and CmpSymbol+  * [#784](https://github.com/clash-lang/clash-compiler/pull/784): Print whether `Id` is global or local in ppr output+  * [#781](https://github.com/clash-lang/clash-compiler/pull/781): Use naming contexts in register names+  * [#1061](https://github.com/clash-lang/clash-compiler/pull/1061): Add 'usedArguments' to BlackBoxHaskell blackboxes+ * Fixes issues:+  * [#974](https://github.com/clash-lang/clash-compiler/issues/974): Fix indirect shadowing in `reduceNonRepPrim`+  * [#964](https://github.com/clash-lang/clash-compiler/issues/964): SaturatingNum instance of `Index` now behaves correctly when the size of the index overflows+  an `Int`.   * [#810](https://github.com/clash-lang/clash-compiler/issues/810): Verilog backend now correctly specifies type of `BitVector 1`   * [#811](https://github.com/clash-lang/clash-compiler/issues/811): Improve module load behavior in clashi   * [#439](https://github.com/clash-lang/clash-compiler/issues/439): Template Haskell splices and TopEntity annotations can now be used in clashi-  * [#818](https://github.com/clash-lang/clash-compiler/issues/818): Fixed various mistakes in tutorial   * [#662](https://github.com/clash-lang/clash-compiler/issues/662): Clash will now constant specialize partially constant constructs   * [#700](https://github.com/clash-lang/clash-compiler/issues/700): Check work content of expression in cast before warning users. Should eliminate a lot of (superfluous) warnings about "specializing on non work-free cast"s.   * [#837](https://github.com/clash-lang/clash-compiler/issues/837): Blackboxes will now report clearer error messages if they're given unexpected arguments.+  * [#869](https://github.com/clash-lang/clash-compiler/issues/869): PLL is no longer duplicated in Blinker.hs example+  * [#749](https://github.com/clash-lang/clash-compiler/issues/749): Clash's dependencies now all work with GHC 8.8, allowing `clash-{prelude,lib,ghc}` to be compiled from Hackage soon.+  * [#871](https://github.com/clash-lang/clash-compiler/issues/871): RTree Bundle instance is now properly lazy+  * [#895](https://github.com/clash-lang/clash-compiler/issues/895): VHDL type error when generating `Maybe (Vec 2 (Signed 8), Index 1)`+  * [#880](https://github.com/clash-lang/clash-compiler/issues/880): Custom bit representations can now be used on product types too+  * [#976](https://github.com/clash-lang/clash-compiler/issues/976): Prevent shadowing in Clash's core evaluator+  * [#1007](https://github.com/clash-lang/clash-compiler/issues/1007): Can't translate domain tagType.Errors.IfStuck...+  * [#967](https://github.com/clash-lang/clash-compiler/issues/967): Naming registers disconnects their output+  * [#990](https://github.com/clash-lang/clash-compiler/issues/990): Internal shadowing bug results in incorrect HDL+  * [#945](https://github.com/clash-lang/clash-compiler/issues/945): Rewrite rules for Vec Applicative Functor+  * [#919](https://github.com/clash-lang/clash-compiler/issues/919): Clash generating invalid Verilog after Vec operations #919+  * [#996](https://github.com/clash-lang/clash-compiler/issues/996): Ambiguous clock when using `ClearOnReset` and `resetGen` together+  * [#701](https://github.com/clash-lang/clash-compiler/issues/701): Unexpected behaviour with the `Synthesize` annotation+  * [#694](https://github.com/clash-lang/clash-compiler/issues/694): Custom bit representation error only with VHDL+  * [#347](https://github.com/clash-lang/clash-compiler/issues/347): topEntity synthesis fails due to insufficient type-level normalisation+  * [#626](https://github.com/clash-lang/clash-compiler/issues/626): Missing Clash.Explicit.Prelude definitions+  * [#960](https://github.com/clash-lang/clash-compiler/issues/626): Blackbox Error Caused by Simple map+  * [#1012](https://github.com/clash-lang/clash-compiler/issues/1012): Case-let doesn't look through ticks+  * [#430](https://github.com/clash-lang/clash-compiler/issues/430): Issue warning when not compiled with `executable-dynamic: True`+  * [#374](https://github.com/clash-lang/clash-compiler/issues/1012): Clash.Sized.Fixed: fromInteger and fromRational don't saturate correctly+  * [#836](https://github.com/clash-lang/clash-compiler/issues/836): Generate warning when `toInteger` blackbox drops MSBs+  * [#1019](https://github.com/clash-lang/clash-compiler/issues/1019): Clash breaks on constants defined in terms of `GHC.Natural.gcdNatural`+  * [#1025](https://github.com/clash-lang/clash-compiler/issues/1025): `inlineCleanup`will not produce empty letrecs anymore+  * [#1030](https://github.com/clash-lang/clash-compiler/issues/1030): `bindConstantVar` will bind (workfree) constructs+  * [#1034](https://github.com/clash-lang/clash-compiler/issues/1034): Error (10137): object "pllLock" on lhs must have a variable data type+  * [#1046](https://github.com/clash-lang/clash-compiler/issues/1046): Don't confuse term/type namespaces in 'lookupIdSubst'+  * [#1041](https://github.com/clash-lang/clash-compiler/issues/1041): Nested product types incorrectly decomposed into ports+  * [#1058](https://github.com/clash-lang/clash-compiler/issues/1058): Prevent substitution warning when using type equalities in top entities+  * [#1033](https://github.com/clash-lang/clash-compiler/issues/1033): Fix issue where Clash breaks when using Clock/Reset/Enable in product types in combination with Synthesize annotations+  * [#1075](https://github.com/clash-lang/clash-compiler/issues/1075): Removed superfluous constraints on 'maybeX' and 'maybeIsX'+  * [#1085](https://github.com/clash-lang/clash-compiler/issues/1085): Suggest exporting topentities if they can't be found in a module+  * [#1065](https://github.com/clash-lang/clash-compiler/pull/1065): Report polymorphic topEntities as errors+  * [#1089](https://github.com/clash-lang/clash-compiler/issues/1089): Respect maxBound in Enum instances for BitVector,Index,Signed,Unsigned -* Small fixes without issue reports:-  * Fix bug in `rnfX` defined for `Down` ([814fd52](https://github.com/clash-lang/clash-compiler/commit/814fd520191123be38af8ef28fc49130424f3b93))+* Fixes without issue reports:+  * Fix bug in `rnfX` defined for `Down` ([baef30e](https://github.com/clash-lang/clash-compiler/commit/baef30eae03dc02ba847ffbb8fae7f365c5287c2))+  * Render numbers inside gensym ([bc76f0f](https://github.com/clash-lang/clash-compiler/commit/bc76f0f1934fd6e6ed9c33bcf950dae21e2f7903))   * Report blackbox name when encountering an error in 'setSym' ([#858](https://github.com/clash-lang/clash-compiler/pull/858))+  * Fix blackbox issues causing Clash to generate invalid HDL ([#865](https://github.com/clash-lang/clash-compiler/pull/865))+  * Treat types with a zero-width custom bit representation like other zero-width constructs ([#874](https://github.com/clash-lang/clash-compiler/pull/874))+  * TH code for auto deriving bit representations now produces nicer error messages ([7190793](https://github.com/clash-lang/clash-compiler/commit/7190793928545f85157f9b8d4b8ec2edb2cd8a26))+  * Adds '--enable-shared-executables' for nix builds; this should make Clash run _much_ faster ([#894](https://github.com/clash-lang/clash-compiler/pull/894))+  * Custom bit representations can now mark fields as zero-width without crashing the compiler ([#898](https://github.com/clash-lang/clash-compiler/pull/898))+  * Throw an error if there's data left to parse after successfully parsing a valid JSON construct ([#904](https://github.com/clash-lang/clash-compiler/pull/904))+  * `Data.gfoldl` is now manually implemented, in turn fixing issues with `gshow` ([#933](https://github.com/clash-lang/clash-compiler/pull/933))+  * Fix a number of issues with blackbox implementations ([#934](https://github.com/clash-lang/clash-compiler/pull/934))+  * Don't inline registers with non-constant clock and reset ([#998](https://github.com/clash-lang/clash-compiler/pull/998))+  * Inline let-binders called [dsN | N <- [1..]] ([#992](https://github.com/clash-lang/clash-compiler/pull/992))+  * ClockGens use their name at the Haskell level [#827](https://github.com/clash-lang/clash-compiler/pull/827)+  * Render numbers inside gensym [#809](https://github.com/clash-lang/clash-compiler/pull/809)+  * Don't overwrite existing binders when specializing [#790](https://github.com/clash-lang/clash-compiler/pull/790)+  * Deshadow in 'caseCase' [#1067](https://github.com/clash-lang/clash-compiler/pull/1067)+  * Deshadow in 'caseLet' and 'nonRepANF' [#1071](https://github.com/clash-lang/clash-compiler/pull/1071) +* Deprecations & removals:+  * Removed support for GHC 8.2 ([#842](https://github.com/clash-lang/clash-compiler/pull/842))+  * Removed support for older cabal versions, only Cabal >=2.2 supported ([#851](https://github.com/clash-lang/clash-compiler/pull/851))+  * Reset and Enable constructors are now only exported from Clash.Signal.Internal+  * [#986](https://github.com/clash-lang/clash-compiler/issues/986) Remove -fclash-allow-zero-width flag+ ## 1.0.0 *September 3rd 2019* * 10x - 50x faster compile times * New features:   * API changes: check the migration guide at the end of `Clash.Tutorial`-  * All memory elements now have an (implicit) enable line; "Gated" clocks have-    been removed as the clock wasn't actually gated, but implemented as an-    enable line.+  * All memory elements now have an (implicit) enable line; "Gated" clocks have been removed as the clock wasn't actually gated, but implemented as an enable line.   * Circuit domains are now configurable in:     * (old) The clock period-    * (new) Clock edge on which memory elements latch their inputs-      (rising edge or falling edge)-    * (new) Whether the reset port of a memory element is level sensitive-      (asynchronous reset) or edge sensitive (synchronous reset)-    * (new) Whether the reset port of a memory element is active-high or-      active-low (negated reset)-    * (new) Whether memory element power on in a configurable/defined state-      (common on FPGAs) or in an undefined state (ASICs)+    * (new) Clock edge on which memory elements latch their inputs (rising edge or falling edge)+    * (new) Whether the reset port of a memory element is level sensitive asynchronous reset) or edge sensitive (synchronous reset)+    * (new) Whether the reset port of a memory element is active-high or active-low (negated reset)+    * (new) Whether memory element power on in a configurable/defined state (common on FPGAs) or in an undefined state (ASICs)      * See the [blog post](https://clash-lang.org/blog/0005-synthesis-domain/) on this new feature   * Data types can now be given custom bit-representations: http://hackage.haskell.org/package/clash-prelude/docs/Clash-Annotations-BitRepresentation.html@@ -50,95 +169,95 @@     See for example: http://hackage.haskell.org/package/clash-lib/docs/Clash-Primitives-Intel-ClockGen.html  * Fixes issues:-  * [#316](https://github.com/clash-lang/clash-prelude/issues/316)-  * [#319](https://github.com/clash-lang/clash-prelude/issues/319)-  * [#323](https://github.com/clash-lang/clash-prelude/issues/323)-  * [#324](https://github.com/clash-lang/clash-prelude/issues/324)-  * [#329](https://github.com/clash-lang/clash-prelude/issues/329)-  * [#331](https://github.com/clash-lang/clash-prelude/issues/331)-  * [#332](https://github.com/clash-lang/clash-prelude/issues/332)-  * [#335](https://github.com/clash-lang/clash-prelude/issues/335)-  * [#348](https://github.com/clash-lang/clash-prelude/issues/348)-  * [#349](https://github.com/clash-lang/clash-prelude/issues/349)-  * [#350](https://github.com/clash-lang/clash-prelude/issues/350)-  * [#351](https://github.com/clash-lang/clash-prelude/issues/351)-  * [#352](https://github.com/clash-lang/clash-prelude/issues/352)-  * [#353](https://github.com/clash-lang/clash-prelude/issues/353)-  * [#358](https://github.com/clash-lang/clash-prelude/issues/358)-  * [#359](https://github.com/clash-lang/clash-prelude/issues/359)-  * [#363](https://github.com/clash-lang/clash-prelude/issues/363)-  * [#364](https://github.com/clash-lang/clash-prelude/issues/364)-  * [#365](https://github.com/clash-lang/clash-prelude/issues/365)-  * [#371](https://github.com/clash-lang/clash-prelude/issues/371)-  * [#372](https://github.com/clash-lang/clash-prelude/issues/372)-  * [#373](https://github.com/clash-lang/clash-prelude/issues/373)-  * [#378](https://github.com/clash-lang/clash-prelude/issues/378)-  * [#380](https://github.com/clash-lang/clash-prelude/issues/380)-  * [#381](https://github.com/clash-lang/clash-prelude/issues/381)-  * [#382](https://github.com/clash-lang/clash-prelude/issues/382)-  * [#383](https://github.com/clash-lang/clash-prelude/issues/383)-  * [#387](https://github.com/clash-lang/clash-prelude/issues/387)-  * [#393](https://github.com/clash-lang/clash-prelude/issues/393)-  * [#396](https://github.com/clash-lang/clash-prelude/issues/396)-  * [#398](https://github.com/clash-lang/clash-prelude/issues/398)-  * [#399](https://github.com/clash-lang/clash-prelude/issues/399)-  * [#401](https://github.com/clash-lang/clash-prelude/issues/401)-  * [#403](https://github.com/clash-lang/clash-prelude/issues/403)-  * [#407](https://github.com/clash-lang/clash-prelude/issues/407)-  * [#412](https://github.com/clash-lang/clash-prelude/issues/412)-  * [#413](https://github.com/clash-lang/clash-prelude/issues/413)-  * [#420](https://github.com/clash-lang/clash-prelude/issues/420)-  * [#422](https://github.com/clash-lang/clash-prelude/issues/422)-  * [#423](https://github.com/clash-lang/clash-prelude/issues/423)-  * [#424](https://github.com/clash-lang/clash-prelude/issues/424)-  * [#438](https://github.com/clash-lang/clash-prelude/issues/438)-  * [#450](https://github.com/clash-lang/clash-prelude/issues/450)-  * [#452](https://github.com/clash-lang/clash-prelude/issues/452)-  * [#455](https://github.com/clash-lang/clash-prelude/issues/455)-  * [#460](https://github.com/clash-lang/clash-prelude/issues/460)-  * [#461](https://github.com/clash-lang/clash-prelude/issues/461)-  * [#463](https://github.com/clash-lang/clash-prelude/issues/463)-  * [#468](https://github.com/clash-lang/clash-prelude/issues/468)-  * [#475](https://github.com/clash-lang/clash-prelude/issues/475)-  * [#476](https://github.com/clash-lang/clash-prelude/issues/476)-  * [#500](https://github.com/clash-lang/clash-prelude/issues/500)-  * [#507](https://github.com/clash-lang/clash-prelude/issues/507)-  * [#512](https://github.com/clash-lang/clash-prelude/issues/512)-  * [#516](https://github.com/clash-lang/clash-prelude/issues/516)-  * [#517](https://github.com/clash-lang/clash-prelude/issues/517)-  * [#526](https://github.com/clash-lang/clash-prelude/issues/526)-  * [#556](https://github.com/clash-lang/clash-prelude/issues/556)-  * [#560](https://github.com/clash-lang/clash-prelude/issues/560)-  * [#566](https://github.com/clash-lang/clash-prelude/issues/566)-  * [#567](https://github.com/clash-lang/clash-prelude/issues/567)-  * [#569](https://github.com/clash-lang/clash-prelude/issues/569)-  * [#573](https://github.com/clash-lang/clash-prelude/issues/573)-  * [#575](https://github.com/clash-lang/clash-prelude/issues/575)-  * [#581](https://github.com/clash-lang/clash-prelude/issues/581)-  * [#582](https://github.com/clash-lang/clash-prelude/issues/582)-  * [#586](https://github.com/clash-lang/clash-prelude/issues/586)-  * [#588](https://github.com/clash-lang/clash-prelude/issues/588)-  * [#591](https://github.com/clash-lang/clash-prelude/issues/591)-  * [#596](https://github.com/clash-lang/clash-prelude/issues/596)-  * [#601](https://github.com/clash-lang/clash-prelude/issues/601)-  * [#607](https://github.com/clash-lang/clash-prelude/issues/607)-  * [#629](https://github.com/clash-lang/clash-prelude/issues/629)-  * [#637](https://github.com/clash-lang/clash-prelude/issues/637)-  * [#644](https://github.com/clash-lang/clash-prelude/issues/644)-  * [#647](https://github.com/clash-lang/clash-prelude/issues/647)-  * [#661](https://github.com/clash-lang/clash-prelude/issues/661)-  * [#668](https://github.com/clash-lang/clash-prelude/issues/668)-  * [#677](https://github.com/clash-lang/clash-prelude/issues/677)-  * [#678](https://github.com/clash-lang/clash-prelude/issues/678)-  * [#682](https://github.com/clash-lang/clash-prelude/issues/682)-  * [#691](https://github.com/clash-lang/clash-prelude/issues/691)-  * [#703](https://github.com/clash-lang/clash-prelude/issues/703)-  * [#713](https://github.com/clash-lang/clash-prelude/issues/713)-  * [#715](https://github.com/clash-lang/clash-prelude/issues/715)-  * [#727](https://github.com/clash-lang/clash-prelude/issues/727)-  * [#730](https://github.com/clash-lang/clash-prelude/issues/730)-  * [#736](https://github.com/clash-lang/clash-prelude/issues/736)-  * [#738](https://github.com/clash-lang/clash-prelude/issues/738)+  * [#316](https://github.com/clash-lang/clash-compiler/issues/316)+  * [#319](https://github.com/clash-lang/clash-compiler/issues/319)+  * [#323](https://github.com/clash-lang/clash-compiler/issues/323)+  * [#324](https://github.com/clash-lang/clash-compiler/issues/324)+  * [#329](https://github.com/clash-lang/clash-compiler/issues/329)+  * [#331](https://github.com/clash-lang/clash-compiler/issues/331)+  * [#332](https://github.com/clash-lang/clash-compiler/issues/332)+  * [#335](https://github.com/clash-lang/clash-compiler/issues/335)+  * [#348](https://github.com/clash-lang/clash-compiler/issues/348)+  * [#349](https://github.com/clash-lang/clash-compiler/issues/349)+  * [#350](https://github.com/clash-lang/clash-compiler/issues/350)+  * [#351](https://github.com/clash-lang/clash-compiler/issues/351)+  * [#352](https://github.com/clash-lang/clash-compiler/issues/352)+  * [#353](https://github.com/clash-lang/clash-compiler/issues/353)+  * [#358](https://github.com/clash-lang/clash-compiler/issues/358)+  * [#359](https://github.com/clash-lang/clash-compiler/issues/359)+  * [#363](https://github.com/clash-lang/clash-compiler/issues/363)+  * [#364](https://github.com/clash-lang/clash-compiler/issues/364)+  * [#365](https://github.com/clash-lang/clash-compiler/issues/365)+  * [#371](https://github.com/clash-lang/clash-compiler/issues/371)+  * [#372](https://github.com/clash-lang/clash-compiler/issues/372)+  * [#373](https://github.com/clash-lang/clash-compiler/issues/373)+  * [#378](https://github.com/clash-lang/clash-compiler/issues/378)+  * [#380](https://github.com/clash-lang/clash-compiler/issues/380)+  * [#381](https://github.com/clash-lang/clash-compiler/issues/381)+  * [#382](https://github.com/clash-lang/clash-compiler/issues/382)+  * [#383](https://github.com/clash-lang/clash-compiler/issues/383)+  * [#387](https://github.com/clash-lang/clash-compiler/issues/387)+  * [#393](https://github.com/clash-lang/clash-compiler/issues/393)+  * [#396](https://github.com/clash-lang/clash-compiler/issues/396)+  * [#398](https://github.com/clash-lang/clash-compiler/issues/398)+  * [#399](https://github.com/clash-lang/clash-compiler/issues/399)+  * [#401](https://github.com/clash-lang/clash-compiler/issues/401)+  * [#403](https://github.com/clash-lang/clash-compiler/issues/403)+  * [#407](https://github.com/clash-lang/clash-compiler/issues/407)+  * [#412](https://github.com/clash-lang/clash-compiler/issues/412)+  * [#413](https://github.com/clash-lang/clash-compiler/issues/413)+  * [#420](https://github.com/clash-lang/clash-compiler/issues/420)+  * [#422](https://github.com/clash-lang/clash-compiler/issues/422)+  * [#423](https://github.com/clash-lang/clash-compiler/issues/423)+  * [#424](https://github.com/clash-lang/clash-compiler/issues/424)+  * [#438](https://github.com/clash-lang/clash-compiler/issues/438)+  * [#450](https://github.com/clash-lang/clash-compiler/issues/450)+  * [#452](https://github.com/clash-lang/clash-compiler/issues/452)+  * [#455](https://github.com/clash-lang/clash-compiler/issues/455)+  * [#460](https://github.com/clash-lang/clash-compiler/issues/460)+  * [#461](https://github.com/clash-lang/clash-compiler/issues/461)+  * [#463](https://github.com/clash-lang/clash-compiler/issues/463)+  * [#468](https://github.com/clash-lang/clash-compiler/issues/468)+  * [#475](https://github.com/clash-lang/clash-compiler/issues/475)+  * [#476](https://github.com/clash-lang/clash-compiler/issues/476)+  * [#500](https://github.com/clash-lang/clash-compiler/issues/500)+  * [#507](https://github.com/clash-lang/clash-compiler/issues/507)+  * [#512](https://github.com/clash-lang/clash-compiler/issues/512)+  * [#516](https://github.com/clash-lang/clash-compiler/issues/516)+  * [#517](https://github.com/clash-lang/clash-compiler/issues/517)+  * [#526](https://github.com/clash-lang/clash-compiler/issues/526)+  * [#556](https://github.com/clash-lang/clash-compiler/issues/556)+  * [#560](https://github.com/clash-lang/clash-compiler/issues/560)+  * [#566](https://github.com/clash-lang/clash-compiler/issues/566)+  * [#567](https://github.com/clash-lang/clash-compiler/issues/567)+  * [#569](https://github.com/clash-lang/clash-compiler/issues/569)+  * [#573](https://github.com/clash-lang/clash-compiler/issues/573)+  * [#575](https://github.com/clash-lang/clash-compiler/issues/575)+  * [#581](https://github.com/clash-lang/clash-compiler/issues/581)+  * [#582](https://github.com/clash-lang/clash-compiler/issues/582)+  * [#586](https://github.com/clash-lang/clash-compiler/issues/586)+  * [#588](https://github.com/clash-lang/clash-compiler/issues/588)+  * [#591](https://github.com/clash-lang/clash-compiler/issues/591)+  * [#596](https://github.com/clash-lang/clash-compiler/issues/596)+  * [#601](https://github.com/clash-lang/clash-compiler/issues/601)+  * [#607](https://github.com/clash-lang/clash-compiler/issues/607)+  * [#629](https://github.com/clash-lang/clash-compiler/issues/629)+  * [#637](https://github.com/clash-lang/clash-compiler/issues/637)+  * [#644](https://github.com/clash-lang/clash-compiler/issues/644)+  * [#647](https://github.com/clash-lang/clash-compiler/issues/647)+  * [#661](https://github.com/clash-lang/clash-compiler/issues/661)+  * [#668](https://github.com/clash-lang/clash-compiler/issues/668)+  * [#677](https://github.com/clash-lang/clash-compiler/issues/677)+  * [#678](https://github.com/clash-lang/clash-compiler/issues/678)+  * [#682](https://github.com/clash-lang/clash-compiler/issues/682)+  * [#691](https://github.com/clash-lang/clash-compiler/issues/691)+  * [#703](https://github.com/clash-lang/clash-compiler/issues/703)+  * [#713](https://github.com/clash-lang/clash-compiler/issues/713)+  * [#715](https://github.com/clash-lang/clash-compiler/issues/715)+  * [#727](https://github.com/clash-lang/clash-compiler/issues/727)+  * [#730](https://github.com/clash-lang/clash-compiler/issues/730)+  * [#736](https://github.com/clash-lang/clash-compiler/issues/736)+  * [#738](https://github.com/clash-lang/clash-compiler/issues/738)  ## 0.99.3 *July 28th 2018* * Fixes bugs:@@ -150,16 +269,38 @@   * Create empty component when result needs 0 bits   * Evaluator performs BigNat arithmetic +* Features:+  * Bundle and BitPack instances up to and including 62-tuples+  * Handle undefined writes to RAM properly+  * Handle undefined clock enables properly++ ## 0.99.1 *May 12th 2018* * Allow `~NAME[N]` tag inside `~GENSYM[X]` * Support HDL record selector generation [#313](https://github.com/clash-lang/clash-compiler/pull/313) * `InlinePrimitive` support: specify HDL primitives inline with Haskell code+* Support for `ghc-typelits-natnormalise-0.6.1`+* `Lift` instances for `TopEntity` and `PortName`+* `InlinePrimitive` support: specify HDL primitives inline with Haskell code  ## 0.99 *March 31st 2018* * New features:-  * Support for `clash-prelude-0.99`:-      * Explicit clock and reset arguments-      * Overhaul of `TopEntity` annotations+  * Major API overhaul: check the migration guide at the end of `Clash.Tutorial`+  * New features:+    * Explicit clock and reset arguments+    * Rename `CLaSH` to `Clash`+    * Implicit/`Hidden` clock and reset arguments using a combination of+    `reflection` and `ImplicitParams`.+    * Large overhaul of `TopEntity`  annotations+    * PLL and other clock sources can now be instantiated using regular functions:+    `Clash.Intel.ClockGen` and `Clash.Xilinx.ClockGen`.+    * DDR registers:+      * Generic/ASIC: `Clash.Explicit.DDR`+      * Intel: `Clash.Intel.DDR`+      * Xilinx: `Clash.Intel.Xilinx`+  * `Bit` is now a `newtype` instead of a `type` synonym and will be mapped to+    a HDL scalar instead of an array of one (e.g `std_logic` instead of+    `std_logic_vector(0 downto 0)`)   * 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@@ -169,357 +310,10 @@   * 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:-  * Eagerness bug in `regEn` [#104](https://github.com/clash-lang/clash-prelude/issues/104) (Thanks to @cbiffle)+## Older versions+Check out:+ * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-prelude/CHANGELOG.md+ * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-lib/CHANGELOG.md+ * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-ghc/CHANGELOG.md -## 0.7.1 *April 11th 2017*-* New features:-  * Support distribution of primitive templates with Cabal/Hackage packages [commit](https://github.com/clash-lang/clash-compiler/commit/82cd31863aafcbaf3bdbf7746d89d13859af5aaf)-  * Find memory data files and primitive files relative to import dirs (`-i<DIR>`)-  * Add 'clashi' program and 'clash-ghc' package [#208](https://github.com/clash-lang/clash-compiler/issues/208), thanks to @thoughtpolice-* Fixes bugs:-  * `case (EmptyCase ty) of ty' { ... }` -> `EmptyCase ty'` [#198](https://github.com/clash-lang/clash-compiler/issues/198)-  * `BitVector.split#` apply the correct type arguments -## 0.7.0.1 *January 17th 2017-* Fixes bugs:-  * Include HsVersions.h in source distribution--## 0.7 *January 16th 2017*-* New features:-  * Support for `clash-prelude` 0.11-  * Primitive templates can include QSys files-  * VHDL blackboxes: support additional libraries and uses keywords in generated VHDL-  * Highly limited Float/Double support (literals and `Rational` conversion), hidden behind the `-clash-float-support` flag.-* Fixes bugs:-  * Reduce type families inside clock period calculation [#180](https://github.com/clash-lang/clash-compiler/issues/180)-  * Only output signed literals as hex when they're multiple of 4 bits [#187](https://github.com/clash-lang/clash-compiler/issues/187)-  * Correctly print negative hex literals--## 0.6.24 *October 17th 20168-* Call generatePrimMap after loadModules [#175](https://github.com/clash-lang/clash-compiler/pull/175)-* Fixes bugs:-  * (System)Verilog: CLaSH.Sized.Vector.imap primitive gets indices in reverse order-  * Template Haskell splices are run twice-  * CLaSH errors out when observing the constructor for `Signal` [#174](https://github.com/clash-lang/clash-compiler/issues/174)--## 0.6.23 *August 18th 2015*-* Fixes bugs:-  * Type families are not being reduced correctly  [#167](https://github.com/clash-lang/clash-compiler/issues/167)-  * (System)Verilog: Fix primitives for {Signed,Unsigned} rotateL# and rotateR# [#169](https://github.com/clash-lang/clash-compiler/issues/169)--## 0.6.22 *August 3rd 2016*-* Fixes bugs:-  * Bug in DEC transformation overwrites case-alternatives-  * Bug in DEC transformation creates non-representable let-binders-  * VHDL: Incorrect primitive for `Integer`s `ltInteger#` and `geInteger#`-  * (System)Verilog: Fix primitive for CLaSH.Sized.Internal.Signed.mod# and GHC.Type.Integer.modInteger [#164](https://github.com/clash-lang/clash-compiler/issues/164)--## 0.6.21 *July 19th 2016*-* Fixes bugs:-  * Rounding error in `logBase` calculation-  * VHDL: Incorrect primitive for `Index`s `*#`-  * VHDL: Incorrect handling of `Index`s `fromInteger#` and `maxBound#` primitives for values larger than 2^MACHINE_WIDTH--## 0.6.20 *July 15th 2016*-* New features:-  * Better error location reporting-* Fixes bugs:-  * `CLaSH.Sized.Internal.Unsigned.maxBound#` not evaluated at compile-time [#155](https://github.com/clash-lang/clash-compiler/issues/155)-  * `CLaSH.Sized.Internal.Unsigned.minBound#` not evaluated at compile-time [#157](https://github.com/clash-lang/clash-compiler/issues/157)-  * Values of type Index 'n', where 'n' > 2^MACHINE_WIDTH, incorrectly considered non-synthesisable due to overflow-  * VHDL: Types in generated types.vhdl incorrectly sorted-  * Casts of CLaSH numeric types result in incorrect VHDL/Verilog (Such casts are now reported as an error)--## 0.6.19 *June 9th 2016*-* Fixes bugs:-  * `Eq` instance of `Vec` sometimes not synthesisable-  * VHDL: Converting product types to std_logic_vector fails when the `clash-hdlsyn Vivado` flag is enabled--## 0.6.18 *June 7th 2016*-* New features:-  * DEC transformation also lifts HO-primitives applied to "interesting" primitives (i.e. `zipWith (*)`)-  * New `-clash-hdlsyn Xilinx` flag to generate HDL tweaked for Xilinx synthesis tools (both ISE and Vivado)-* Fixes bugs:-  * replicate unfolded incorrectly [#150](https://github.com/clash-lang/clash-compiler/issues/150)-  * `imap` is not unrolled [#151](https://github.com/clash-lang/clash-compiler/issues/151)-  * VHDL: Incorrect primitive specification for `snatToInteger` [#149](https://github.com/clash-lang/clash-compiler/issues/149)--## 0.6.17 *April 7th 2016*-* New features:-  * Up to 2x reduced compilation times when working with large `Vec` literals-* Fixes bugs:-  * VHDL: Incorrect primitives for `BitVector`s `quot#` and `rem#`-  * VHDL: Bit indexing and replacement primitives fail to synthesise in Synopsis tools-  * Bug in DEC transformation throws CLaSH into an endless loop [#140](https://github.com/clash-lang/clash-compiler/issues/140)-  * Missed constant folding opportunity results in an error [#50](https://github.com/clash-lang/clash-prelude/issues/50)--## 0.6.16 *March 21st 2016*-* New features:-  * Also generate testbench for circuits without input ports [#135](https://github.com/clash-lang/clash-compiler/issues/135)-* Fixes bugs:-  * `clockWizard` broken [#49](https://github.com/clash-lang/clash-prelude/issues/49)--## 0.6.15 *March 15th 2016*-* Fixes bugs:-  * XST cannot finds "_types" package unless it is prefixed with "work." [#133](https://github.com/clash-lang/clash-compiler/pull/133)--## 0.6.14 *March 15th 2016*-* Fixes bugs:-  * XST cannot finds "_types" package unless it is prefixed with "work." [#133](https://github.com/clash-lang/clash-compiler/pull/133)--## 0.6.13 *March 14th 2016*-* Fixes bugs:-  * Not all lambda's in a function position removed--## 0.6.12 *March 14th 2016*-* Fixes bugs:-  * Not all lambda's in a function position removed due to bad eta-expansion [#132](https://github.com/clash-lang/clash-compiler/issues/132)--## 0.6.11 *March 11th 2016*-* New features:-  * Add support for HDL synthesis tool specific HDL generation:-    * New `-clash-hdlsyn Vivado` flag to generate HDL tweaked for Xilinx Vivado-  * Preserve more Haskell names in generated HDL [#128](https://github.com/clash-lang/clash-compiler/issues/128)-* Fixes bugs:-  * VHDL: Vivado fails to infer block ram [#127](https://github.com/clash-lang/clash-compiler/issues/127)-    * Users must use the `-clash-hdlsyn Vivado` flag in order to generate Xilinx Vivado specific HDL for which Vivado can infer block RAM.--## 0.6.10 *February 10th 2016*-* New features:-  * hdl files can be written to a directory (set by the `-clash-hdldir` flag) other than the current working directory [#125](https://github.com/clash-lang/clash-compiler/issues/125).-    Also respects the `-outputdir` directory, _unless_:-      * `-clash-hdldir` is set to a different directory.-      * `-hidir`, `-stubdir`, and `-dumbdir` are not the same directory as `-odir`-* Fixes bugs:-  * `caseCon` transformation does not work on non-exhaustive case-expressions [#123](https://github.com/clash-lang/clash-compiler/issues/123)-  * VHDL: insufficient type-qualifiers for concatenation operator [#121](https://github.com/clash-lang/clash-compiler/issues/121)-  * Primitive reductions don't look through `Signal` [#126](https://github.com/clash-lang/clash-compiler/issues/126)--## 0.6.9 *January 29th 2016*-* New features:-  * Support for `Debug.Trace.trace`, thanks to @ggreif--* Fixes bugs:-  * `case undefined of ...` should reduce to `undefined` [#116](https://github.com/clash-lang/clash-compiler/issues/109)-  * VHDL/SystemVerilog: BlockRAM elements must be bit vectors [#113](https://github.com/clash-lang/clash-compiler/issues/113)-  * Type families obscure eligibility for synthesis [#114](https://github.com/clash-lang/clash-compiler/issues/114)--## 0.6.8 *January 13th 2016*-* New features:-  * Support for Haskell's: `Char`, `Int8`, `Int16`, `Int32`, `Int64`, `Word`, `Word8`, `Word16`, `Word32`, `Word64`.-  * Int/Word/Integer bitwidth for generated HDL is configurable using the `-clash-intwidth=N` flag, where `N` can be either 32 or 64.-* Fixes bugs:-  * Cannot reduce `case error ... of ...` to `error ...` [#109](https://github.com/clash-lang/clash-compiler/issues/109)--## 0.6.7 *December 21st 2015*-* Support for `unbound-generics-0.3`-* New features:-  * Only look for 'topEntity' in the root module. [#22](https://github.com/clash-lang/clash-compiler/issues/22)-* Fixes bugs:-  * Unhelpful error message when GHC is not in PATH [#104](https://github.com/clash-lang/clash-compiler/issues/104)--## 0.6.6 *December 11th 2015*-* New features:-  * Remove all existing HDL files before generating new ones. This can be disabled by the `-clash-noclean` flag. [#96](https://github.com/clash-lang/clash-compiler/issues/96)-  * Support for `clash-prelude` 0.10.4--## 0.6.5 *November 17th 2015*-* Fixes bugs:-  * Integer literals used as arguments not always properly annotated with their type.-  * Verilog: Name collision in verilog code [#93](https://github.com/clash-lang/clash-compiler/issues/93)-  * (System)Verilog: Integer literals missing "32'sd" prefix when used in assignments.-  * VHDL: Integer literals should only be capped to 32-bit when used in assignments.-  * Verilog: HO-primitives incorrect for nested vectors.--## 0.6.4 *November 12th 2015*-* Fixes bugs:-  * Reversing alternatives is not meaning preserving for literal patterns [#91](https://github.com/clash-lang/clash-compiler/issues/91)-  * DEC: root of the case-tree must contain at least 2 alternatives [#92](https://github.com/clash-lang/clash-compiler/issues/92)-  * Do not generate overlapping literal patterns in VHDL [#91](https://github.com/clash-lang/clash-compiler/issues/91)--## 0.6.3 *October 24th 2015*-* New features:-  * Improve DEC transformation: consider alternatives before the subject when checking for disjoint expressions.-* Fixes bugs:-  * DEC: don't generate single-branch case-expressions [#90](https://github.com/clash-lang/clash-compiler/issues/90)--## 0.6.2 *October 21st 2015*-* New features:-  * Support `clash-prelude` 0.10.2--* Fixes bugs:-  * CLaSH interpreter was reading '.ghci' file instead of '.clashi' file [#87](https://github.com/clash-lang/clash-compiler/issues/87)-  * DEC: Subject and alternatives are not disjoint [#88](https://github.com/clash-lang/clash-compiler/issues/88)--## 0.6.1 *October 16th 2015*-* New features:-  * Support for `clash-prelude` 0.10.1-  * Transformation that lifts applications of the same function out of alternatives of case-statements. e.g.--    ```haskell-    case x of-      A -> f 3 y-      B -> f x x-      C -> h x-    ```--    is transformed into:--    ```haskell-    let f_arg0 = case x of {A -> 3; B -> x}-        f_arg1 = case x of {A -> y; B -> x}-        f_out  = f f_arg0 f_arg1-    in  case x of-          A -> f_out-          B -> f_out-          C -> h x-    ```--* Fixes bugs:-  * clash won't run when not compiled with usual ghc [#82](https://github.com/clash-lang/clash-compiler/issues/82)-  * Fail to generate VHDL with blockRamFile' in clash-ghc 0.6 [#85](https://github.com/clash-lang/clash-compiler/issues/85)-  * Case-statements acting like normal decoder circuits are erroneously synthesised to priority decoder circuits.--## 0.6 *October 3rd 2015*-* New features:-  * Support `clash-prelude-0.10`-  * Pattern matching on `CLaSH.Sized.Vector`'s `:>` is now supported-  * Unroll "definitions" of the following primitives: `fold`, `dfold`, `foldr`--## 0.5.15 *September 21st 2015*-* New features:-  * Report simulation time in (System)Verilog assert messages--* Fixes bugs:-  * Performance bug: top-level definitions of type "Signal" erroneously inlined.-  * Fix Index maxBound [#79](https://github.com/clash-lang/clash-compiler/pull/79)--## 0.5.14 *September 14th 2015*-* New features:-  * Completely unroll "definitions" of some higher-order primitives with non-representable argument or result vectors:-    It is now possible to translate e.g. `f xs ys = zipWith ($) (map (+) xs) ys :: Vec 4 Int -> Vec 4 Int -> Vec 4 Int`--* Fixes bugs:-  * Converting Bool to Unsigned generates broken VHDL [#77](https://github.com/clash-lang/clash-compiler/issues/77)-  * `topLet` transformation erroneously not performed in a top-down traversal-  * Specialisation limit unchecked on types and constants-  * Vector of functions cannot be translated [#25](https://github.com/clash-lang/clash-compiler/issues/25 )-  * CLaSH fails to generate VHDL when map is applied [#78](https://github.com/clash-lang/clash-compiler/issues/78)--## 0.5.13 *September 8th 2015*-* Fixes bugs:-  * Cannot translate GHC `MachLabel` literal-  * Maybe (Index n) not translatable to VHDL [#75](https://github.com/clash-lang/clash-compiler/issues/75)--## 0.5.12 *September 7th 2015*-* New features:-  * Modest compilation time speed-up. Compilation time of the [I2C](https://github.com/clash-lang/clash-compiler/tree/master/examples/i2c) module on my machine went down from 43s to 24s, and maximum memory usage went down from 840 MB to 700 MB.--* Fixes bugs:-  * Bug in VHDL ROM generation [#69](https://github.com/clash-lang/clash-compiler/issues/69)-  * Clash running out of memory on Simple-ish project [#70](https://github.com/clash-lang/clash-compiler/issues/70)-  * Fix asyncRom VHDL primitive [#71](https://github.com/clash-lang/clash-compiler/pull/71)-  * Fix primitive for CLaSH.Sized.Internal.Signed.size# [#72](https://github.com/clash-lang/clash-compiler/pull/72)-  * rem and quot on Signed are broken [#73](https://github.com/clash-lang/clash-compiler/issues/73)--## 0.5.11 *August 2nd 2015*-* New features:-  * Re-enable GHC's strictness analysis pass, which improves dead-code removal, which hopefully leads to smaller circuits.--## 0.5.10 *July 9th 2015*-* New features:-  * Use new VHDL backend which outputs VHDL-93 instead of VHDL-2002: generated VHDL is now accepted by a larger number of tools.-  * Treat all so-called bottom values (`error "FOO"`, `let x = x in x`, etc.) occuring in installed libraries as `undefined`.-    Before, there were (very) rare situations where we couldn't find the expressions belonging to a function and demanded a BlackBox, even though we knew the expression would be a bottom value.-    Now, we stop demanding a BlackBox for such a function and simply treat it as `undefined`, thus allowing a greater range of circuit descriptions that we can compile.--## 0.5.9 *June 26th 2015*-* New features:-  * Use new verilog backend which outputs Verilog-2001 instead of Verilog-2005: generated Verilog is now accepted by Altera/Quartus--* Fixes bugs:-  * `--systemverilog` switch incorrectly generates verilog code instead of systemverilog code--## 0.5.8 *June 25th 2015*-* New features:-  * Support for copying string literals from Haskell to generated code-  * Support `clash-prelude-0.9`-  * Size at below which functions are always inlined is configurable, run with `-clash-inline-below=N` to set the size limit to `N`--## 0.5.7 *June 3rd 2015*-* New features:-  * New Verilog backend, run `:verilog` in interactive mode, or `--verilog` for batch mode-  * Generated component names are prefixed by the name of the module containing the `topEntity`--## 0.5.6 *May 18th 2015*-* New features:-  * Inlining limit is configurable, run with `-clash-inline-limit=N` to set the inlining limit to `N`-  * Specialisation limit is configurable, run with `clash-spec-limit=N` to set the inline limit to `N`-  * Debug level is configurable, run with `-clash-debug <LEVEL>` where `<LEVEL>` can be: `DebugNone, DebugFinal, DebugName, DebugApplied, DebugAll`. Be default, `clash` runs with `DebugNone`.--* Fixes bugs:-  * Extend evaluator for `GHC.Integer.Type.minusInteger` and `CLaSH.Promoted.Nat.SNat`.--## 0.5.5 *May 5th 2015*-* New features:-  * `TopEntity` wrappers are now specified as `ANN` annotation pragmas [#42](https://github.com/clash-lang/clash-compiler/issues/42)--## 0.5.4 *May 1st 2015*-* New features:-  * Generate wrappers around `topEntity` that have constant names and types--## 0.5.3 *April 24th 2015*-* Fixes bugs:-  * Fix bug where not enough array type definitions were created by the VHDL backend--## 0.5.2 *April 21st 2015*-* Use latest ghc-typelits-natnormalise--## 0.5.1 *April 20th 2015*-* New features:-  * GHC 7.10 support-  * Update to clash-prelude 0.7.2-  * Use http://hackage.haskell.org/package/ghc-typelits-natnormalise typechecker plugin for better type-level natural number handling--## 0.5 *March 11th 2015*-* New features:-  * SystemVerilog backend. [#45](https://github.com/clash-lang/clash-compiler/issues/45)--## 0.4.1 *February 4th 2015*-* Include bug fixes from clash-lib 0.4.1--## 0.4 *November 17th 2014*-* New features:-  * Support for clash-prelude 0.6--* Fixes bugs:-  * clash-ghc ignores "-package-db" flag [#35](https://github.com/christiaanb/clash2/issues/35)--## 0.3.3 *August 12th 2014*-* Fixes bugs:-  * Compile with GHC 7.8.3 [#31](https://github.com/christiaanb/clash2/issues/31)--## 0.3.2 *June 5th 2014*--* Fixes bugs:-  * Type synonym improperly expanded [#17](https://github.com/christiaanb/clash2/issues/17)-  * BlackBox for `Signed` `maxBound` and `minBound` generate incorrect VHDL. [#19](https://github.com/christiaanb/clash2/issues/19)-  * Generate failure code in the VHDL for recSelError [#23](https://github.com/christiaanb/clash2/issues/23)--## 0.3.1 *May 15th 2014*--* New features:-  * Hardcode `fromInteger` for `Signed` and `Unsigned` [#9](https://github.com/christiaanb/clash2/issues/9)-  * Better blackbox operation for vindex [#12](https://github.com/christiaanb/clash2/issues/12)-  * Replace VHDL default hole by error hole [#13](https://github.com/christiaanb/clash2/issues/13)--* Fixes bugs:-  * Update GHC2Core.hs [#1](https://github.com/christiaanb/clash2/issues/1)-  * primitives (clash.sized.vector) [#2](https://github.com/christiaanb/clash2/issues/2)-  * Type families are not expanded [#3](https://github.com/christiaanb/clash2/issues/3)-  * Incorrect vhdl generation for default value in blackbox [#6](https://github.com/christiaanb/clash2/issues/6)-  * Missing begin keyword in Signed/Unsigned JSON files [#16](https://github.com/christiaanb/clash2/issues/16)

@@ -1,5 +1,6 @@+Cabal-version:        2.2 Name:                 clash-ghc-Version:              1.0.1+Version:              1.2.0 Synopsis:             CAES Language for Synchronous Hardware Description:   Clash is a functional hardware description language that borrows both its@@ -29,10 +30,10 @@   * Clash Compiler binary using GHC/Haskell as a frontend   .   .-  Prelude library: <http://hackage.haskell.org/package/clash-prelude>-Homepage:             http://www.clash-lang.org/-bug-reports:          http://github.com/clash-lang/clash-compiler/issues-License:              BSD2+  Prelude library: <https://hackage.haskell.org/package/clash-prelude>+Homepage:             https://clash-lang.org/+bug-reports:          https://github.com/clash-lang/clash-compiler/issues+License:              BSD-2-Clause License-file:         LICENSE Author:               The Clash Authors Maintainer:           QBayLogic B.V. <devops@qbaylogic.com>@@ -46,14 +47,12 @@                       CHANGELOG.md,                       LICENSE_GHC,                       cbits/PosixSource.h,-                      src-bin-821/Clash/GHCi/HsVersions.h                       src-bin-841/Clash/GHCi/HsVersions.h -Cabal-version:        >=1.10- source-repository head   type: git   location: https://github.com/clash-lang/clash-compiler.git+  subdir: clash-ghc  flag dynamic   description:@@ -85,39 +84,48 @@   extra-libraries:    pthread   default-language:   Haskell2010 +common common-options+  default-language:   Haskell2010+  default-extensions: BangPatterns+                      BinaryLiterals+                      DataKinds+                      DefaultSignatures+                      DeriveDataTypeable+                      DeriveFoldable+                      DeriveFunctor+                      DeriveGeneric+                      DeriveLift+                      DeriveTraversable+                      DerivingStrategies+                      InstanceSigs+                      KindSignatures+                      ScopedTypeVariables+                      StandaloneDeriving+                      TupleSections+                      TypeApplications+                      TypeOperators+                      ViewPatterns++  if impl(ghc >= 8.6)+      default-extensions: NoStarIsType+ library+  import:             common-options   HS-Source-Dirs:     src-ghc, src-bin-common-  -- when we move to `cabal-version: 2.2`, we can use elif instead of these nested ifs, but ghc-8.2 comes with cabal-2.0   if impl(ghc >= 8.7.0)-    HS-Source-Dirs:   src-bin-881-  else-    if impl(ghc >= 8.6.0)-      HS-Source-Dirs:   src-bin-861-    else-      if impl(ghc >= 8.4.1)-        HS-Source-Dirs:   src-bin-841-      else-        if impl(ghc >= 8.2.1)-          HS-Source-Dirs:   src-bin-821+    HS-Source-Dirs: src-bin-881+  elif impl(ghc >= 8.6.0)+    HS-Source-Dirs: src-bin-861+  elif impl(ghc >= 8.4.1)+    HS-Source-Dirs: src-bin-841 -  default-language:   Haskell2010-  GHC-Options:        -Wall -fno-warn-name-shadowing+  GHC-Options:        -Wall   CPP-Options:        -DGHCI-  default-extensions: ForeignFunctionInterface-                      UnboxedTuples-                      FlexibleInstances-                      MagicHash-                      CPP-                      PatternGuards-                      NondecreasingIndentation    other-extensions:   FlexibleContexts                       OverloadedStrings                       RecordWildCards-                      ScopedTypeVariables                       TemplateHaskell-                      TupleSections-                      ViewPatterns    Build-Depends:      array                     >= 0.4      && < 0.6,                       base                      >= 4.10     && < 5,@@ -126,27 +134,28 @@                       containers                >= 0.5.4.0  && < 0.7,                       directory                 >= 1.2      && < 1.4,                       filepath                  >= 1.3      && < 1.5,-                      ghc                       >= 8.2.0    && < 8.9,+                      ghc                       >= 8.4.0    && < 8.9,                       process                   >= 1.2      && < 1.7,                       hashable                  >= 1.1.2.3  && < 1.4,-                      haskeline                 >= 0.7.0.3  && < 0.8,-                      lens                      >= 4.0.5    && < 4.19,+                      haskeline                 >= 0.7.0.3  && < 0.9,+                      lens                      >= 4.10     && < 4.20,                       mtl                       >= 2.1.1    && < 2.3,+                      split                     >= 0.2.3    && < 0.3,                       text                      >= 1.2.2    && < 1.3,                       transformers              >= 0.5.2.0  && < 0.6,                       unordered-containers      >= 0.2.1.0  && < 0.3, -                      clash-lib                 >= 1.0      && < 1.1,-                      clash-prelude             >= 1.0      && < 1.1,+                      clash-lib                 == 1.2.0,+                      clash-prelude             == 1.2.0,                       concurrent-supply         >= 0.1.7    && < 0.2,-                      ghc-typelits-extra        >= 0.3.1    && < 0.4,+                      ghc-typelits-extra        >= 0.3.2    && < 0.4,                       ghc-typelits-knownnat     >= 0.6      && < 0.8,                       ghc-typelits-natnormalise >= 0.6      && < 0.8,                       deepseq                   >= 1.3.0.2  && < 1.5,                       time                      >= 1.4.0.1  && < 1.10,-                      ghc-boot                  >= 8.2.0    && < 8.9,+                      ghc-boot                  >= 8.4.0    && < 8.9,                       ghc-prim                  >= 0.3.1.0  && < 0.6,-                      ghci                      >= 8.2.0    && < 8.9,+                      ghci                      >= 8.4.0    && < 8.9,                       uniplate                  >= 1.6.12   && < 1.8,                       reflection                >= 2.1.2    && < 3.0,                       integer-gmp               >= 1.0.1.0  && < 2.0,@@ -165,6 +174,8 @@    Include-dirs:       cbits   C-Sources:          cbits/hschooks.c++  Autogen-Modules:    Paths_clash_ghc    Exposed-Modules:    Clash.Main 

@@ -1,68 +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 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 */

@@ -1,3893 +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, 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.GHCi.Common-import           Clash.Netlist.BlackBox.Types (HdlSyn)-import           Clash.Util (clashLibVersion, reportTimeDiff)-import qualified Data.Time.Clock as Clock-import qualified Paths_clash_ghc--import           Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)---------------------------------------------------------------------------------data GhciSettings = GhciSettings {-        availableCommands :: [Command],-        shortHelpText     :: String,-        fullHelpText      :: String,-        defPrompt         :: PromptFunction,-        defPromptCont     :: PromptFunction-    }--defaultGhciSettings :: IORef ClashOpts -> GhciSettings-defaultGhciSettings opts =-    GhciSettings {-        availableCommands = ghciCommands opts,-        shortHelpText     = defShortHelpText,-        defPrompt         = default_prompt,-        defPromptCont     = default_prompt_cont,-        fullHelpText      = defFullHelpText-    }--ghciWelcomeMsg :: String-ghciWelcomeMsg = "Clashi, version " ++ Data.Version.showVersion Paths_clash_ghc.version ++-                 " (using clash-lib, version " ++ Data.Version.showVersion clashLibVersion ++-                 "):\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 behavior 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 -> Bool -> Maybe (Maybe Int) -> backend)-         -> IORef ClashOpts-         -> [FilePath]-         -> InputT GHCi ()-makeHDL' backend opts lst = go =<< case lst of-  srcs@(_:_) -> return srcs-  []         -> do-    modGraph <- GHC.getModuleGraph-    let sortedGraph = GHC.topSortModuleGraph False modGraph Nothing-    return $ case (reverse sortedGraph) of-      ((AcyclicSCC top) : _) -> maybeToList $ (GHC.ml_hs_file . GHC.ms_location) top-      _                      -> []- where-  go srcs = do-    dflags <- GHC.getSessionDynFlags-    goX dflags srcs `gfinally` recover dflags--  goX dflags srcs = do-    (dflagsX,_,_) <- parseDynamicFlagsCmdLine dflags-                       [ noLoc "-fobject-code"   -- For #439-                       , noLoc "-fforce-recomp"  -- Actually compile to object-code-                       , noLoc "-keep-tmp-files" -- To prevent linker errors from-                                                 -- multiple calls to :hdl command-                       ]-    _ <- GHC.setSessionDynFlags dflagsX-    reloadModule ""-    makeHDL backend opts srcs--  recover dflags = do-    _ <- GHC.setSessionDynFlags dflags-    reloadModule ""--makeHDL :: GHC.GhcMonad m-        => Clash.Backend.Backend backend-        => (Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> backend)-        -> IORef ClashOpts-        -> [FilePath]-        -> m ()-makeHDL backend optsRef srcs = do-  dflags <- GHC.getSessionDynFlags-  liftIO $ do startTime <- Clock.getCurrentTime-              opts0  <- readIORef optsRef-              let opts1  = opts0 { opt_color = useColor dflags }-              let iw     = opt_intWidth opts1-                  fp     = opt_floatSupport opts1-                  syn    = opt_hdlSyn opts1-                  color  = opt_color opts1-                  esc    = opt_escapedIds opts1-                  frcUdf = opt_forceUndefined opts1-                  hdl    = Clash.Backend.hdlKind backend'-                  -- determine whether `-outputdir` was used-                  outputDir = do odir <- objectDir dflags-                                 hidir <- hiDir dflags-                                 sdir <- stubDir dflags-                                 ddir <- dumpDir dflags-                                 if all (== odir) [hidir,sdir,ddir]-                                    then Just odir-                                    else Nothing-                  idirs = importPaths dflags-                  opts2 = opts1 { opt_hdlDir = maybe outputDir Just (opt_hdlDir opts1)-                                , opt_importPaths = idirs}-                  backend' = backend iw syn esc frcUdf--              checkMonoLocalBinds dflags-              checkImportDirs opts0 idirs--              primDirs <- Clash.Backend.primDirs backend'--              forM_ srcs $ \src -> do-                -- Generate bindings:-                let dbs = reverse [p | PackageDB (PkgConfFile p) <- packageDBFlags dflags]-                (bindingsMap,tcm,tupTcm,topEntities,primMap,reprs) <--                  generateBindings color primDirs idirs dbs hdl src (Just dflags)-                prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime-                let prepStartDiff = reportTimeDiff prepTime startTime-                putStrLn $ "GHC+Clash: Loading modules cumulatively took " ++ prepStartDiff--                -- Generate HDL:-                Clash.Driver.generateHDL-                  (buildCustomReprs reprs)-                  bindingsMap-                  (Just backend')-                  primMap-                  tcm-                  tupTcm-                  (ghcTypeToHWType iw fp)-                  reduceConstant-                  topEntities-                  opts2-                  (startTime,prepTime)--makeVHDL :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VHDLState)--makeVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> VerilogState)--makeSystemVerilog :: IORef ClashOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> 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

@@ -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 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)

@@ -1,454 +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(..),-        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)"

@@ -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")

@@ -1,1016 +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---- 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 qualified Clash.Backend-import           Clash.Backend.SystemVerilog (SystemVerilogState)-import           Clash.Backend.VHDL    (VHDLState)-import           Clash.Backend.Verilog (VerilogState)-import           Clash.Driver.Types (ClashOpts (..), defClashOpts)-import           Clash.GHC.ClashFlags-import           Clash.Netlist.BlackBox.Types (HdlSyn (..))-import           Clash.Util (clashLibVersion)-import           Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)-import           Clash.GHC.Util (handleClashException)---------------------------------------------------------------------------------- ToDo:---- time commands when run with -v--- user ways--- Win32 support: proper signal handling--- reading the package configuration file is too slow--- -K<size>---------------------------------------------------------------------------------- GHC's command-line interface--defaultMain :: [String] -> IO ()-defaultMain = flip withArgs $ do-   initGCStatistics -- See Note [-Bsymbolic and hooks]-   hSetBuffering stdout LineBuffering-   hSetBuffering stderr LineBuffering--   -- 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 defClashOpts-    (argv2, clashFlagWarnings) <- parseClashFlags r argv1--    -- 2. Parse the "mode" flags (--make, --interactive etc.)-    (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2-    let flagWarnings = modeFlagWarnings ++ clashFlagWarnings--    -- If all we want to do is something like showing the version number-    -- then do it now, before we start a GHC session etc. This makes-    -- getting basic information much more resilient.--    -- In particular, if we wait until later before giving the version-    -- number then bootstrapping gets confused, as it tries to find out-    -- what version of GHC it's using before package.conf exists, so-    -- starting the session fails.-    case mode of-        Left preStartupMode ->-            do case preStartupMode of-                   ShowSupportedExtensions   -> showSupportedExtensions-                   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 = wantedLanguageExtensions dflags--                ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"-                ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"-                ghcTyLitKNPlugin   = GHC.mkModuleName "GHC.TypeLits.KnownNat.Solver"-                dflagsExtra1 = dflagsExtra-                                  { DynFlags.pluginModNames = nub $-                                      ghcTyLitNormPlugin : ghcTyLitExtrPlugin :-                                      ghcTyLitKNPlugin :-                                      DynFlags.pluginModNames dflagsExtra-                                  }--            case postStartupMode of-                Left preLoadMode ->-                    liftIO $ do-                        case preLoadMode of-                            ShowInfo               -> showInfo dflagsExtra1-                            ShowGhcUsage           -> showGhcUsage  dflagsExtra1-                            ShowGhciUsage          -> showGhciUsage dflagsExtra1-                            PrintWithDynFlags f    -> putStrLn (f dflagsExtra1)-                Right postLoadMode ->-                    main' postLoadMode dflagsExtra1 argv3 flagWarnings r---main' :: PostLoadMode -> DynFlags -> [Located String] -> [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, HscNothing,     NoLink)-               DoVerilog       -> (CompManager, HscNothing,     NoLink)-               DoSystemVerilog -> (CompManager, HscNothing,     NoLink)-               _               -> (OneShot,     dflt_target,    LinkBinary)--  let dflags1 = dflags0{ ghcMode   = mode,-                         hscTarget = lang,-                         ghcLink   = link,-                         verbosity = case postLoadMode of-                                         DoEval _ -> 0-                                         _other   -> 1-                        }--      -- turn on -fimplicit-import-qualified for GHCi now, so that it-      -- can be overriden from the command-line-      -- XXX: this should really be in the interactive DynFlags, but-      -- we don't set that until later in interactiveUI-      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--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 _                   = 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 -> Bool -> Maybe (Maybe Int) ->  backend)-         -> IORef ClashOpts -> [(String,Maybe Phase)] -> Ghc ()-makeHDL' _       _ []   = throwGhcException (CmdLineError "No input files")-makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs--makeVHDL :: IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) ->  VHDLState)--makeVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) ->  VerilogState)--makeSystemVerilog ::  IORef ClashOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (Clash.Backend.initBackend :: Int -> HdlSyn -> Bool -> Maybe (Maybe Int) -> 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 ()

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-}@@ -6,8 +6,6 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly@@ -175,7 +173,7 @@ 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"+                 "):\nhttps://clash-lang.org/  :? for help"  ghciCommands :: IORef ClashOpts -> [Command] ghciCommands opts = map mkCmd [@@ -625,30 +623,36 @@   case maybe_exprs of         Nothing ->           do+            -- Set different defaulting rules (See #280)+            runGHCiExpressions ["default ((),[],Integer,Int,Double,String)"]             -- 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 ()+            runGHCiExpressions exprs    -- and finally, exit   liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi." +runGHCiExpressions :: [String] -> GHCi ()+runGHCiExpressions exprs = do+    enqueueCommands exprs+    let hdle e = do st <- getGHCiState+                    -- flush the interpreter's stdout/stderr on exit (#3890)+                    flushInterpBuffers+                    -- Jump through some hoops to get the+                    -- current progname in the exception text:+                    -- <progname>: <exception>+                    liftIO $ withProgName (progname st)+                           $ topHandler e+                           -- this used to be topHandlerFastExit, see #2228+    runInputTWithPrefs defaultPrefs defaultSettings $ do+        -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+        _ <- runCommands' hdle+             (Just $ hdle (toException $ ExitFailure 1) >> return ())+             (return Nothing)+        return ()+ runGHCiInput :: InputT GHCi a -> GHCi a runGHCiInput f = do     dflags <- getDynFlags@@ -2007,7 +2011,7 @@                   tcm                   tupTcm                   (ghcTypeToHWType iw fp)-                  reduceConstant+                  primEvaluator                   topEntities                   opts2                   (startTime,prepTime)

@@ -1,7 +1,7 @@-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}  -- | Get information on modules, expressions, and identifiers module Clash.GHCi.UI.Info

@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+ {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly 

@@ -7,6 +7,7 @@ -----------------------------------------------------------------------------  {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+ module Clash.GHCi.UI.Tags (   createCTagsWithLineNumbersCmd,   createCTagsWithRegExesCmd,

@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}+ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}  -----------------------------------------------------------------------------@@ -79,6 +81,7 @@  -- clash additions import           Paths_clash_ghc+import           Clash.GHCi.Common (checkClashDynamic) import           Clash.GHCi.UI (makeHDL) import           Exception (gcatch) import           Data.IORef (IORef, newIORef, readIORef)@@ -92,7 +95,7 @@ import           Clash.GHC.ClashFlags import           Clash.Netlist.BlackBox.Types (HdlSyn (..)) import           Clash.Util (clashLibVersion)-import           Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)+import           Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions) import           Clash.GHC.Util (handleClashException)  -----------------------------------------------------------------------------@@ -160,13 +163,14 @@                    ShowSupportedExtensions   -> showSupportedExtensions                    ShowVersion               -> showVersion                    ShowNumVersion            -> putStrLn cProjectVersion-                   ShowOptions isInteractive -> showOptions isInteractive+                   ShowOptions isInteractive -> showOptions isInteractive r         Right postStartupMode ->             -- start our GHC session             GHC.runGhc (Just libDir) $ do              dflags <- GHC.getSessionDynFlags-            let dflagsExtra = wantedLanguageExtensions dflags+            liftIO (checkClashDynamic dflags)+            let dflagsExtra = setWantedLanguageExtensions dflags                  ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"                 ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"@@ -838,12 +842,13 @@                                 , ")"                                 ] -showOptions :: Bool -> IO ()-showOptions isInteractive = putStr (unlines availableOptions)+showOptions :: Bool -> IORef ClashOpts -> IO ()+showOptions isInteractive = putStr . unlines . availableOptions     where-      availableOptions = concat [-        flagsForCompletion isInteractive,-        map ('-':) (getFlagNames mode_flags)+      availableOptions opts = concat+        [ flagsForCompletion isInteractive+        , map ('-':) (getFlagNames mode_flags)+        , map ('-':) (getFlagNames (flagsClash opts))         ]       getFlagNames opts         = map flagName opts 

@@ -1,4 +1,6 @@-{-# LANGUAGE RecordWildCards, LambdaCase #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+ module Clash.GHCi.Leak   ( LeakIndicators   , getLeakIndicators

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-}@@ -6,8 +6,6 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly@@ -181,7 +179,7 @@ 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"+                 "):\nhttps://clash-lang.org/  :? for help"  ghciCommands :: IORef ClashOpts -> [Command] ghciCommands opts = map mkCmd [@@ -633,30 +631,36 @@   case maybe_exprs of         Nothing ->           do+            -- Set different defaulting rules (See #280)+            runGHCiExpressions ["default ((),[],Integer,Int,Double,String)"]             -- 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 ()+            runGHCiExpressions exprs    -- and finally, exit   liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi." +runGHCiExpressions :: [String] -> GHCi ()+runGHCiExpressions exprs = do+    enqueueCommands exprs+    let hdle e = do st <- getGHCiState+                    -- flush the interpreter's stdout/stderr on exit (#3890)+                    flushInterpBuffers+                    -- Jump through some hoops to get the+                    -- current progname in the exception text:+                    -- <progname>: <exception>+                    liftIO $ withProgName (progname st)+                           $ topHandler e+                           -- this used to be topHandlerFastExit, see #2228+    runInputTWithPrefs defaultPrefs defaultSettings $ do+        -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+        _ <- runCommands' hdle+             (Just $ hdle (toException $ ExitFailure 1) >> return ())+             (return Nothing)+        return ()+ runGHCiInput :: InputT GHCi a -> GHCi a runGHCiInput f = do     dflags <- getDynFlags@@ -2056,7 +2060,7 @@                   tcm                   tupTcm                   (ghcTypeToHWType iw fp)-                  reduceConstant+                  primEvaluator                   topEntities                   opts2                   (startTime,prepTime)

@@ -1,7 +1,7 @@-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}  -- | Get information on modules, expressions, and identifiers module Clash.GHCi.UI.Info

@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+ {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly 

@@ -7,6 +7,7 @@ -----------------------------------------------------------------------------  {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+ module Clash.GHCi.UI.Tags (   createCTagsWithLineNumbersCmd,   createCTagsWithRegExesCmd,

@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}+ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}  -----------------------------------------------------------------------------@@ -81,6 +83,7 @@  -- clash additions import           Paths_clash_ghc+import           Clash.GHCi.Common (checkClashDynamic) import           Clash.GHCi.UI (makeHDL) import           Exception (gcatch) import           Data.IORef (IORef, newIORef, readIORef)@@ -95,7 +98,7 @@ import           Clash.GHC.ClashFlags import           Clash.Netlist.BlackBox.Types (HdlSyn (..)) import           Clash.Util (clashLibVersion)-import           Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)+import           Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions) import           Clash.GHC.Util (handleClashException)  -----------------------------------------------------------------------------@@ -151,13 +154,14 @@                    ShowSupportedExtensions   -> showSupportedExtensions                    ShowVersion               -> showVersion                    ShowNumVersion            -> putStrLn cProjectVersion-                   ShowOptions isInteractive -> showOptions isInteractive+                   ShowOptions isInteractive -> showOptions isInteractive r         Right postStartupMode ->             -- start our GHC session             GHC.runGhc (Just libDir) $ do              dflags <- GHC.getSessionDynFlags-            let dflagsExtra = wantedLanguageExtensions dflags+            liftIO (checkClashDynamic dflags)+            let dflagsExtra = setWantedLanguageExtensions dflags                  ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"                 ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"@@ -832,12 +836,13 @@                                 , ")"                                 ] -showOptions :: Bool -> IO ()-showOptions isInteractive = putStr (unlines availableOptions)+showOptions :: Bool -> IORef ClashOpts -> IO ()+showOptions isInteractive = putStr . unlines . availableOptions     where-      availableOptions = concat [-        flagsForCompletion isInteractive,-        map ('-':) (getFlagNames mode_flags)+      availableOptions opts = concat+        [ flagsForCompletion isInteractive+        , map ('-':) (getFlagNames mode_flags)+        , map ('-':) (getFlagNames (flagsClash opts))         ]       getFlagNames opts         = map flagName opts 

@@ -1,4 +1,6 @@-{-# LANGUAGE RecordWildCards, LambdaCase #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+ module Clash.GHCi.Leak   ( LeakIndicators   , getLeakIndicators

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-}@@ -6,9 +6,6 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly@@ -184,7 +181,7 @@ 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"+                 "):\nhttps://clash-lang.org/  :? for help"  ghciCommands :: IORef ClashOpts -> [Command] ghciCommands opts = map mkCmd [@@ -670,30 +667,37 @@   case maybe_exprs of         Nothing ->           do+            -- Set different defaulting rules (See #280)+            runGHCiExpressions ["default ((),[],Integer,Int,Double,String)"]+             -- enter the interactive loop             runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty-        Just exprs -> do+        Just exprs ->             -- 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 ()+            runGHCiExpressions exprs    -- and finally, exit   liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving Clashi." +runGHCiExpressions :: [String] -> GHCi ()+runGHCiExpressions exprs = do+    enqueueCommands exprs+    let hdle e = do st <- getGHCiState+                    -- flush the interpreter's stdout/stderr on exit (#3890)+                    flushInterpBuffers+                    -- Jump through some hoops to get the+                    -- current progname in the exception text:+                    -- <progname>: <exception>+                    liftIO $ withProgName (progname st)+                           $ topHandler e+                           -- this used to be topHandlerFastExit, see #2228+    runInputTWithPrefs defaultPrefs defaultSettings $ do+        -- make `ghc -e` exit nonzero on invalid input, see Trac #7962+        _ <- runCommands' hdle+             (Just $ hdle (toException $ ExitFailure 1) >> return ())+             (return Nothing)+        return ()+ runGHCiInput :: InputT GHCi a -> GHCi a runGHCiInput f = do     dflags <- getDynFlags@@ -2148,7 +2152,7 @@                   tcm                   tupTcm                   (ghcTypeToHWType iw fp)-                  reduceConstant+                  primEvaluator                   topEntities                   opts2                   (startTime,prepTime)

@@ -1,8 +1,7 @@-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns        #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}  -- | Get information on modules, expressions, and identifiers module Clash.GHCi.UI.Info

@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+ {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly 

@@ -7,6 +7,7 @@ -----------------------------------------------------------------------------  {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+ module Clash.GHCi.UI.Tags (   createCTagsWithLineNumbersCmd,   createCTagsWithRegExesCmd,

@@ -1,4 +1,5 @@-{-# LANGUAGE MagicHash, UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}  -- | Utilities for GHCi. module Clash.GHCi.Util where

@@ -1,5 +1,6 @@-{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables, TupleSections #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}+ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}  -----------------------------------------------------------------------------@@ -79,6 +80,7 @@  -- clash additions import           Paths_clash_ghc+import           Clash.GHCi.Common (checkClashDynamic) import           Clash.GHCi.UI (makeHDL) import           Exception (gcatch) import           Data.IORef (IORef, newIORef, readIORef)@@ -93,7 +95,7 @@ import           Clash.GHC.ClashFlags import           Clash.Netlist.BlackBox.Types (HdlSyn (..)) import           Clash.Util (clashLibVersion)-import           Clash.GHC.LoadModules (ghcLibDir, wantedLanguageExtensions)+import           Clash.GHC.LoadModules (ghcLibDir, setWantedLanguageExtensions) import           Clash.GHC.Util (handleClashException)  -----------------------------------------------------------------------------@@ -147,13 +149,14 @@                  ShowSupportedExtensions   -> showSupportedExtensions                  ShowVersion               -> showVersion                  ShowNumVersion            -> putStrLn cProjectVersion-                 ShowOptions isInteractive -> showOptions isInteractive+                 ShowOptions isInteractive -> showOptions isInteractive r       Right postStartupMode ->           -- start our GHC session           GHC.runGhc (Just libDir) $ do            dflags <- GHC.getSessionDynFlags-          let dflagsExtra = wantedLanguageExtensions dflags+          liftIO (checkClashDynamic dflags)+          let dflagsExtra = setWantedLanguageExtensions dflags                ghcTyLitNormPlugin = GHC.mkModuleName "GHC.TypeLits.Normalise"               ghcTyLitExtrPlugin = GHC.mkModuleName "GHC.TypeLits.Extra.Solver"@@ -844,12 +847,13 @@                                 , ")"                                 ] -showOptions :: Bool -> IO ()-showOptions isInteractive = putStr (unlines availableOptions)+showOptions :: Bool -> IORef ClashOpts -> IO ()+showOptions isInteractive = putStr . unlines . availableOptions     where-      availableOptions = concat [-        flagsForCompletion isInteractive,-        map ('-':) (getFlagNames mode_flags)+      availableOptions opts = concat+        [ flagsForCompletion isInteractive+        , map ('-':) (getFlagNames mode_flags)+        , map ('-':) (getFlagNames (flagsClash opts))         ]       getFlagNames opts         = map flagName opts 

@@ -1,16 +1,18 @@-{-# LANGUAGE CPP        #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}  module Clash.GHCi.Common   ( checkImportDirs   , checkMonoLocalBinds   , checkMonoLocalBindsMod+  , checkClashDynamic   ) where  -- Clash import           Clash.Driver.Types     (ClashOpts (..))  -- The GHC interface+import qualified DynFlags #if MIN_VERSION_base(4,11,0) import qualified EnumSet                as GHC (member) -- ghc84, ghc86 #else@@ -64,3 +66,14 @@     doesDirectoryExist dir >>= \case       False -> throwGhcException (CmdLineError $ "Missing directory: " ++ dir)       _     -> return ()++checkClashDynamic :: GHC.DynFlags -> IO ()+checkClashDynamic dflags = do+  let isStatic = case lookup "GHC Dynamic" (DynFlags.compilerInfo dflags) of+        Just "YES" -> False+        _          -> True+  when isStatic+    (hPutStrLn stderr (unlines+      ["WARNING: Clash is linked statically, which can lead to long startup times."+      ,"See https://gitlab.haskell.org/ghc/ghc/issues/15524"+      ]))

@@ -5,6 +5,7 @@    Entry point for the @clash@ executable. -}+ module Main   ( main -- :: IO ()   ) where

@@ -5,25 +5,30 @@   Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE CPP           #-}-{-# LANGUAGE LambdaCase    #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}  module Clash.GHC.ClashFlags   ( parseClashFlags+  , flagsClash   ) where -import CmdLineParser-import Panic-import SrcLoc+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)+import           Control.Monad+import           Data.Char                      (isSpace)+import           Data.IORef+import           Data.List                      (dropWhileEnd)+import           Data.List.Split                (splitOn)+import qualified Data.Set                       as Set+import           Text.Read                      (readMaybe) +import           Clash.Driver.Types+import           Clash.Netlist.BlackBox.Types   (HdlSyn (..))+ parseClashFlags :: IORef ClashOpts -> [Located String]                 -> IO ([Located String] #if MIN_VERSION_ghc(8,4,1)@@ -57,6 +62,7 @@ flagsClash :: IORef ClashOpts -> [Flag IO] flagsClash r = [     defFlag "fclash-debug"                       $ SepArg (setDebugLevel r)+  , defFlag "fclash-debug-transformations"       $ SepArg (setDebugTransformations r)   , defFlag "fclash-hdldir"                      $ SepArg (setHdlDir r)   , defFlag "fclash-hdlsyn"                      $ SepArg (setHdlSyn r)   , defFlag "fclash-nocache"                     $ NoArg (deprecated "nocache" "no-cache" setNoCache r)@@ -72,12 +78,13 @@   , 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)   , defFlag "fclash-component-prefix"            $ SepArg (liftEwM . setComponentPrefix r)   , defFlag "fclash-old-inline-strategy"         $ NoArg (liftEwM (setOldInlineStrategy r))   , defFlag "fclash-no-escaped-identifiers"      $ NoArg (liftEwM (setNoEscapedIds r))   , defFlag "fclash-compile-ultra"               $ NoArg (liftEwM (setUltra r))   , defFlag "fclash-force-undefined"             $ OptIntSuffix (setUndefined r)+  , defFlag "fclash-aggressive-x-optimization"   $ NoArg (liftEwM (setAggressiveXOpt r))+  , defFlag "fclash-inline-workfree-limit"       $ IntSuffix (liftEwM . setInlineWFLimit r)   ]  -- | Print deprecated flag warning@@ -113,11 +120,24 @@   -> IO () setInlineConstantLimit r n = modifyIORef r (\c -> c {opt_inlineConstantLimit = toEnum n}) +setInlineWFLimit+  :: IORef ClashOpts+  -> Int+  -> IO ()+setInlineWFLimit r n = modifyIORef r (\c -> c {opt_inlineWFCacheLimit = toEnum n})+ setSpecLimit :: IORef ClashOpts              -> Int              -> IO () setSpecLimit r n = modifyIORef r (\c -> c {opt_specLimit = n}) +setDebugTransformations :: IORef ClashOpts -> String -> EwM IO ()+setDebugTransformations r s =+  liftEwM (modifyIORef r (\c -> c {opt_dbgTransformations = transformations}))+ where+  transformations = Set.fromList (filter (not . null) (map trim (splitOn "," s)))+  trim = dropWhileEnd isSpace . dropWhile isSpace+ setDebugLevel :: IORef ClashOpts               -> String               -> EwM IO ()@@ -170,11 +190,6 @@ setFloatSupport :: IORef ClashOpts -> IO () setFloatSupport r = modifyIORef r (\c -> c {opt_floatSupport = True}) -setAllowZeroWidth :: IORef ClashOpts -> EwM IO ()-setAllowZeroWidth _ = do-  addWarn ("-fclash-allow-zero-width is deprecated and will be removed in Clash 1.0")-  -- liftEwM (modifyIORef r (\c -> c {opt_allowZero = True}))- setComponentPrefix   :: IORef ClashOpts   -> String@@ -196,3 +211,7 @@            " not in range [0,1]") setUndefined r iM =   liftEwM (modifyIORef r (\c -> c {opt_forceUndefined = Just iM}))++setAggressiveXOpt :: IORef ClashOpts -> IO ()+setAggressiveXOpt r = modifyIORef r (\c -> c { opt_aggressiveXOpt = True })+

@@ -6,32 +6,28 @@   Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE KindSignatures    #-}-{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE UnboxedTuples     #-}-{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UnboxedTuples #-} -module Clash.GHC.Evaluator where+module Clash.GHC.Evaluator+  ( primEvaluator+  ) where -import           Control.Applicative (liftA2) import           Control.Concurrent.Supply  (Supply,freshId) import           Control.DeepSeq            (force) import           Control.Exception          (ArithException(..), Exception, tryJust, evaluate)-import           Control.Monad              (ap)+import           Control.Monad.State.Strict (State, MonadState)+import qualified Control.Monad.State.Strict as State import           Control.Monad.Trans.Except (runExcept) import           Data.Bits import           Data.Char           (chr,ord) import qualified Data.Either         as Either-import qualified Data.IntMap         as IntMap-import           Data.Maybe-  (fromMaybe, mapMaybe, catMaybes)+import           Data.Maybe (fromMaybe, mapMaybe) import qualified Data.List           as List import qualified Data.Primitive.ByteArray as ByteArray import           Data.Proxy          (Proxy)@@ -45,10 +41,11 @@ import           GHC.Integer   (decodeDoubleInteger,encodeDoubleInteger,compareInteger,orInteger,andInteger,    xorInteger,complementInteger,absInteger,signumInteger)+import           GHC.Integer.GMP.Internals+  (Integer (..), BigNat (..)) import           GHC.Natural import           GHC.Prim import           GHC.Real            (Ratio (..))-import           GHC.Stack           (HasCallStack) import           GHC.TypeLits        (KnownNat) import           GHC.Types           (IO (..)) import           GHC.Word@@ -57,7 +54,8 @@ import           BasicTypes          (Boxity (..)) import           Name                (getSrcSpan, nameOccName, occNameString) import           PrelNames-  (typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey)+  (typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey,+   trueDataConKey, falseDataConKey) import           SrcLoc              (wiredInSrcSpan) import qualified TyCon import           TysWiredIn          (tupleTyCon)@@ -66,8 +64,7 @@ import           Clash.Class.BitPack (pack,unpack) import           Clash.Core.DataCon  (DataCon (..)) import           Clash.Core.Evaluator-  (Heap (..), PrimEvaluator, Stack, Value (..), valToTerm, whnf, integerLiteral,-  naturalLiteral)+import           Clash.Core.Evaluator.Types import           Clash.Core.Literal  (Literal (..)) import           Clash.Core.Name   (Name (..), NameSort (..), mkUnsafeSystemName)@@ -99,24 +96,75 @@ import Clash.Sized.Internal.Unsigned (Unsigned (..)) import Clash.XException (isX) -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'))+primEvaluator :: PrimEvaluator+primEvaluator = (reduceConstant, unwindPrim) -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')+-- | Evaluation of primitive operations.+-- TODO This should really be in Clash.GHC.Evaluator -- the evaluator in+-- clash-lib should NEVER refer to GHC primitives.+unwindPrim :: PrimUnwind+unwindPrim tcm ty tys vs v [] m+  | primName ty `elem` [ "Clash.Sized.Internal.Index.fromInteger#"+                       , "GHC.CString.unpackCString#"+                       , "Clash.Transformations.removedArg"+                       , "GHC.Prim.MutableByteArray#"+                       ]+              -- The above primitives are actually values, and not operations.+  = unwind tcm m (PrimVal ty tys (vs ++ [v]))+  | primName ty == "Clash.Sized.Internal.BitVector.fromInteger#"+  = case (vs,v) of+    ([naturalLiteral -> Just n,mask], integerLiteral -> Just i) ->+      unwind tcm m (PrimVal ty tys [Lit (NaturalLiteral n)+                                             ,mask+                                             ,Lit (IntegerLiteral (wrapUnsigned n i))])+    _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))+  | primName ty == "Clash.Sized.Internal.BitVector.fromInteger##"+  = case (vs,v) of+    ([mask], integerLiteral -> Just i) ->+      unwind tcm m (PrimVal ty tys [mask+                                             ,Lit (IntegerLiteral (wrapUnsigned 1 i))])+    _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))+  | primName ty == "Clash.Sized.Internal.Signed.fromInteger#"+  = case (vs,v) of+    ([naturalLiteral -> Just n],integerLiteral -> Just i) ->+      unwind tcm m (PrimVal ty tys [Lit (NaturalLiteral n)+                                             ,Lit (IntegerLiteral (wrapSigned n i))])+    _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))+  | primName ty == "Clash.Sized.Internal.Unsigned.fromInteger#"+  = case (vs,v) of+    ([naturalLiteral -> Just n],integerLiteral -> Just i) ->+      unwind tcm m (PrimVal ty tys [Lit (NaturalLiteral n)+                                             ,Lit (IntegerLiteral (wrapUnsigned n i))])+    _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))+  | otherwise = mPrimStep m tcm (forcePrims m) ty tys (vs ++ [v]) m +unwindPrim tcm ty tys vs v [e] m0+  | primName ty `elem` [ "Clash.Sized.Vector.lazyV"+                       , "Clash.Sized.Vector.replicate"+                       , "Clash.Sized.Vector.replace_int"+                       , "GHC.Classes.&&"+                       , "GHC.Classes.||"+                       ]+  = let (m1,i) = newLetBinding tcm m0 e+    in  mPrimStep m0 tcm (forcePrims m0) ty tys (vs ++ [v,Suspend (Var i)]) m1++unwindPrim _ ty tys vs (collectValueTicks -> (v, ts)) (e:es) m =+  Just . setTerm e $ stackPush (PrimApply ty tys (vs ++ [foldr TickValue v ts]) es) m+++newtype PrimEvalMonad a = PEM (State Supply a)+  deriving (Functor, Applicative, Monad, MonadState Supply)+ instance MonadUnique PrimEvalMonad where-  getUniqueM = PEM (\s -> case freshId s of (!i,!s') -> (i,s'))+  getUniqueM = PEM $ State.state (\s -> case freshId s of (!i,!s') -> (i,s')) -reduceConstant :: PrimEvaluator-reduceConstant isSubj tcm h k nm pInfo tys args = case nm of+runPEM :: PrimEvalMonad a -> Supply -> (a, Supply)+runPEM (PEM m) = State.runState m++reduceConstant :: PrimStep+reduceConstant tcm isSubj pInfo tys args mach = case primName pInfo of ----------------- -- GHC.Prim.Char# -----------------@@ -624,32 +672,29 @@     "GHC.Prim.newByteArray#"-    | [iV,PrimVal rwNm rwTy _ _] <- args+    | [iV,PrimVal rwTy _ _] <- args     , [i] <- intLiterals' [iV]     -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty            (Just tupTc) = lookupUniqMap tupTcNm tcm            [tupDc] = tyConDataCons tupTc-           Heap (gh,p) gbl ph ids is0 = h+           p = primCount mach            lit = Literal (ByteArrayLiteral (Vector.replicate (fromInteger i) 0))-           h' = Heap (IntMap.insert p lit gh,p+1) gbl ph ids is0            mbaTy = mkFunTy intPrimTy (last tyArgs)            newE = mkApps (Data tupDc) (map Right tyArgs ++-                    [Left (Prim rwNm rwTy)-                    ,Left (mkApps (Prim "GHC.Prim.MutableByteArray#"-                                        (PrimInfo mbaTy WorkNever))+                    [Left (Prim rwTy)+                    ,Left (mkApps (Prim (PrimInfo "GHC.Prim.MutableByteArray#" mbaTy WorkNever))                                   [Left (Literal . IntLiteral $ toInteger p)])                     ])-       in Just (h',k,newE)+       in Just . setTerm newE $ primInsert p lit mach    "GHC.Prim.setByteArray#"-    | [PrimVal _mbaNm _mbaTy _ [baV]+    | [PrimVal _mbaTy _ [baV]       ,offV,lenV,cV-      ,PrimVal rwNm rwTy _ _+      ,PrimVal rwTy _ _       ] <- args     , [ba,off,len,c] <- intLiterals' [baV,offV,lenV,cV]-    -> let Heap (gh,p) gbl ph ids is0 = h-           Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =-              IntMap.lookup (fromInteger ba) gh+    -> let Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =+              primLookup (fromInteger ba) mach            !(I# off') = fromInteger off            !(I# len') = fromInteger len            !(I# c')   = fromInteger c@@ -658,19 +703,17 @@                   svoid (setByteArray# mba off' len' c')                   ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)            ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))-           h'  = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) gbl ph ids is0-       in Just (h',k,Prim rwNm rwTy)+       in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach    "GHC.Prim.writeWordArray#"-    | [PrimVal _mbaNm _mbaTy _  [baV]+    | [PrimVal _mbaTy _  [baV]       ,iV,wV-      ,PrimVal rwNm rwTy _ _+      ,PrimVal rwTy _ _       ] <- args     , [ba,i] <- intLiterals' [baV,iV]     , [w] <- wordLiterals' [wV]-    -> let Heap (gh,p) gbl ph ids is0 = h-           Just (Literal (ByteArrayLiteral (Vector.Vector off len ba1))) =-              IntMap.lookup (fromInteger ba) gh+    -> let Just (Literal (ByteArrayLiteral (Vector.Vector off len ba1))) =+              primLookup (fromInteger ba) mach            !(I# i') = fromInteger i            !(W# w') = fromIntegral w            ba2 = unsafeDupablePerformIO $ do@@ -678,21 +721,19 @@                   svoid (writeWordArray# mba i' w')                   ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)            ba3 = Literal (ByteArrayLiteral (Vector.Vector off len ba2))-           h'  = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) gbl ph ids is0-       in Just (h',k,Prim rwNm rwTy)+       in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach    "GHC.Prim.unsafeFreezeByteArray#"-    | [PrimVal _mbaNm _mbaTy _ [baV]-      ,PrimVal rwNm rwTy _ _+    | [PrimVal _mbaTy _ [baV]+      ,PrimVal rwTy _ _       ] <- args     , [ba] <-  intLiterals' [baV]     -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty            (Just tupTc) = lookupUniqMap tupTcNm tcm            [tupDc] = tyConDataCons tupTc-           Heap (gh,_) _ _ _ _ = h-           Just ba' = IntMap.lookup (fromInteger ba) gh+           Just ba' = primLookup (fromInteger ba) mach        in  reduce $ mkApps (Data tupDc) (map Right tyArgs ++-                      [Left (Prim rwNm rwTy)+                      [Left (Prim rwTy)                       ,Left ba'])    "GHC.Prim.sizeofByteArray#"@@ -707,32 +748,31 @@        in  reduce (Literal (WordLiteral (toInteger (W# w))))    "GHC.Prim.getSizeofMutBigNat#"-    | [PrimVal _mbaNm _mbaTy _ [baV]-      ,PrimVal rwNm rwTy _ _+    | [PrimVal _mbaTy _ [baV]+      ,PrimVal rwTy _ _       ] <- args     , [ba] <- intLiterals' [baV]     -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty            (Just tupTc) = lookupUniqMap tupTcNm tcm            [tupDc] = tyConDataCons tupTc-           Heap (gh,_) _ _ _ _ = h-           Just (Literal (ByteArrayLiteral ba')) = IntMap.lookup (fromInteger ba) gh+           Just (Literal (ByteArrayLiteral ba')) = primLookup (fromInteger ba) mach            lit = Literal (IntLiteral (toInteger (Vector.length ba')))        in  reduce $ mkApps (Data tupDc) (map Right tyArgs ++-                      [Left (Prim rwNm rwTy)+                      [Left (Prim rwTy)                       ,Left lit])    "GHC.Prim.resizeMutableByteArray#"-    | [PrimVal mbaNm mbaTy _ [baV]+    | [PrimVal mbaTy _ [baV]       ,iV-      ,PrimVal rwNm rwTy _ _+      ,PrimVal rwTy _ _       ] <- args     , [ba,i] <- intLiterals' [baV,iV]     -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty            (Just tupTc) = lookupUniqMap tupTcNm tcm            [tupDc] = tyConDataCons tupTc-           Heap (gh,p) gbl ph ids is0 = h+           p = primCount mach            Just (Literal (ByteArrayLiteral (Vector.Vector 0 _ ba1)))-            = IntMap.lookup (fromInteger ba) gh+            = primLookup (fromInteger ba) mach            !(I# i') = fromInteger i            ba2 = unsafeDupablePerformIO $ do                    ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1@@ -740,43 +780,39 @@                                  (# s', mba' #) -> (# s', ByteArray.MutableByteArray mba' #))                    ByteArray.unsafeFreezeByteArray mba'            ba3 = Literal (ByteArrayLiteral (Vector.Vector 0 (I# i') ba2))-           h'  = Heap (IntMap.insert p ba3 gh,p+1) gbl ph ids is0            newE = mkApps (Data tupDc) (map Right tyArgs ++-                    [Left (Prim rwNm rwTy)-                    ,Left (mkApps (Prim mbaNm mbaTy)+                    [Left (Prim rwTy)+                    ,Left (mkApps (Prim mbaTy)                                   [Left (Literal . IntLiteral $ toInteger p)])                     ])-       in  Just (h',k,newE)+       in Just . setTerm newE $ primInsert p ba3 mach    "GHC.Prim.shrinkMutableByteArray#"-    | [PrimVal _mbaNm _mbaTy _ [baV]+    | [PrimVal _mbaTy _ [baV]       ,lenV-      ,PrimVal rwNm rwTy _ _+      ,PrimVal rwTy _ _       ] <- args     , [ba,len] <- intLiterals' [baV,lenV]-    -> let Heap (gh,p) gbl ph ids is0 = h-           Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =-              IntMap.lookup (fromInteger ba) gh+    -> let Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen ba1))) =+              primLookup (fromInteger ba) mach            !(I# len') = fromInteger len            ba2 = unsafeDupablePerformIO $ do                   ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1                   svoid (shrinkMutableByteArray# mba len')                   ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray mba)            ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))-           h'  = Heap (IntMap.insert (fromInteger ba) ba3 gh,p) gbl ph ids is0-       in Just (h',k,Prim rwNm rwTy)+       in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger ba) ba3 mach    "GHC.Prim.copyByteArray#"     | [Lit (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray src_ba)))       ,src_offV-      ,PrimVal _mbaNm _mbaTy _ [dst_mbaV]+      ,PrimVal _mbaTy _ [dst_mbaV]       ,dst_offV, nV-      ,PrimVal rwNm rwTy _ _+      ,PrimVal rwTy _ _       ] <- args     , [src_off,dst_mba,dst_off,n] <- intLiterals' [src_offV,dst_mbaV,dst_offV,nV]-    -> let Heap (gh,p) gbl ph ids is0 = h-           Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen dst_ba))) =-              IntMap.lookup (fromInteger dst_mba) gh+    -> let Just (Literal (ByteArrayLiteral (Vector.Vector voff vlen dst_ba))) =+              primLookup (fromInteger dst_mba) mach            !(I# src_off') = fromInteger src_off            !(I# dst_off') = fromInteger dst_off            !(I# n')       = fromInteger n@@ -785,28 +821,26 @@                   svoid (copyByteArray# src_ba src_off' dst_mba1 dst_off' n')                   ByteArray.unsafeFreezeByteArray (ByteArray.MutableByteArray dst_mba1)            ba3 = Literal (ByteArrayLiteral (Vector.Vector voff vlen ba2))-           h'  = Heap (IntMap.insert (fromInteger dst_mba) ba3 gh,p) gbl ph ids is0-       in Just (h',k,Prim rwNm rwTy)+       in Just . setTerm (Prim rwTy) $ primUpdate (fromInteger dst_mba) ba3 mach    "GHC.Prim.readWordArray#"-    | [PrimVal _mbaNm _mbaTy _  [baV]+    | [PrimVal _mbaTy _  [baV]       ,offV-      ,PrimVal rwNm rwTy _ _+      ,PrimVal rwTy _ _       ] <- args     , [ba,off] <- intLiterals' [baV,offV]     -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty            (Just tupTc) = lookupUniqMap tupTcNm tcm            [tupDc] = tyConDataCons tupTc-           Heap (gh,_) _ _ _ _ = h            Just (Literal (ByteArrayLiteral (Vector.Vector _ _ ba1))) =-              IntMap.lookup (fromInteger ba) gh+              primLookup (fromInteger ba) mach            !(I# off') = fromInteger off            w = unsafeDupablePerformIO $ do                   ByteArray.MutableByteArray mba <- ByteArray.unsafeThawByteArray ba1                   IO (\s -> case readWordArray# mba off' s of                         (# s', w' #) -> (# s',  W# w' #))            newE = mkApps (Data tupDc) (map Right tyArgs ++-                    [Left (Prim rwNm rwTy)+                    [Left (Prim rwTy)                     ,Left (Literal (WordLiteral (toInteger w)))                     ])        in reduce newE@@ -823,7 +857,6 @@                    [ Left (Literal . IntLiteral  . toInteger $ I# p)                    , Left (Literal . IntLiteral  . toInteger $ I# q)]) -   "GHC.Prim.tagToEnum#"     | [ConstTy (TyCon tcN)] <- tys     , [Lit (IntLiteral i)]  <- args@@ -831,26 +864,58 @@                    ; let dcs = tyConDataCons tc                    ; List.find ((== (i+1)) . toInteger . dcTag) dcs                    }-       in ((h,k,) . Data) <$> dc+       in (\e -> setTerm (Data e) mach) <$> 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-         ((nameOcc (dcName lCon) == "GHC.Types.True") &&-          (nameOcc (dcName rCon) == "GHC.Types.True"))+    | [ lArg , rArg ] <- args+    -- evaluation of the arguments is deferred until the evaluation of the unwindPrim+    -- to make `&&` lazy in both arguments+    , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf tcm True (setTerm (valToTerm lArg) $ stackClear mach)+    , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf tcm True (setTerm (valToTerm rArg) $ stackClear mach1)+    -> case [ lArgWHNF, rArgWHNF ] of+         [ Data lCon, Data rCon ] ->+           Just $ mach2+             { mStack = mStack mach+             , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon && isTrueDC rCon)+             } +         [ Data lCon, _ ]+           | isTrueDC lCon -> reduce rArgWHNF+           | otherwise     -> reduce (boolToBoolLiteral tcm ty False)++         [ _, Data rCon ]+           | isTrueDC rCon -> reduce lArgWHNF+           | otherwise     -> reduce (boolToBoolLiteral tcm ty False)++         _ -> Nothing+   "GHC.Classes.||"-    | [DC lCon _-      ,DC rCon _] <- args-    -> reduce $ boolToBoolLiteral tcm ty-         ((nameOcc (dcName lCon) == "GHC.Types.True") ||-          (nameOcc (dcName rCon) == "GHC.Types.True"))+    | [ lArg , rArg ] <- args+    -- evaluation of the arguments is deferred until the evaluation of the unwindPrim+    -- to make `||` lazy in both arguments+    , mach1@Machine{mStack=[],mTerm=lArgWHNF} <- whnf tcm True (setTerm (valToTerm lArg) $ stackClear mach)+    , mach2@Machine{mStack=[],mTerm=rArgWHNF} <- whnf tcm True (setTerm (valToTerm rArg) $ stackClear mach1)+    -> case [ lArgWHNF, rArgWHNF ] of+         [ Data lCon, Data rCon ] ->+           Just $ mach2+             { mStack = mStack mach+             , mTerm = boolToBoolLiteral tcm ty (isTrueDC lCon || isTrueDC rCon)+             } +         [ Data lCon, _ ]+           | isFalseDC lCon -> reduce rArgWHNF+           | otherwise      -> reduce (boolToBoolLiteral tcm ty True)++         [ _, Data rCon ]+           | isFalseDC rCon -> reduce lArgWHNF+           | otherwise      -> reduce (boolToBoolLiteral tcm ty True)++         _ -> Nothing+   "GHC.Classes.divInt#" | Just (i,j) <- intLiterals args     -> reduce (integerToIntLiteral (i `div` j)) @@ -1072,6 +1137,12 @@      let nTy = snd (splitFunForallTy ty) in      reduce (checkNaturalRange1 nTy w id) +  "GHC.Natural.gcdNatural"+    | Just (i,j) <- naturalLiterals args+    ->+     let nTy = snd (splitFunForallTy ty) in+     reduce (checkNaturalRange2 nTy i j gcd)+   -- 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@@ -1085,11 +1156,17 @@     | [Lit (IntLiteral i), Lit (IntLiteral j)] <- args     -> reduce (integerToIntLiteral $ i ^ j) -  -- XXX: Very fragile. /$s^_f/ is a specialized version of ^_f. That means that-  -- it is type applied to some specific type.-  "Data.Singletons.TypeLits.Internal.$s^_f"-    | Just (i,j) <- naturalLiterals args+  -- Type level ^    -- XXX: Very fragile+  -- These is are specialized versions of ^_f, named by some combination of ghc and singletons.+  "Data.Singletons.TypeLits.Internal.$s^_f"            -- ghc-8.4.4, singletons-2.4.1+    | [i,j] <- naturalLiterals' args     -> reduce (Literal (NaturalLiteral (i ^ j)))+  "Data.Singletons.TypeLits.Internal.$fSingI->^@#@$_f" -- ghc-8.6.5, singletons-2.5.1+    | [i,j] <- naturalLiterals' args+    -> reduce (Literal (NaturalLiteral (i ^ j)))+  "Data.Singletons.TypeLits.Internal.%^_f"             -- ghc-8.8.1, singletons-2.6+    | [i,j] <- naturalLiterals' args+    -> reduce (Literal (NaturalLiteral (i ^ j)))    "GHC.TypeLits.natVal"     | [Lit (NaturalLiteral n), _] <- args@@ -1244,8 +1321,8 @@     -> reduce (Literal (DoubleLiteral (toRational (fromInteger i :: Double))))    "GHC.Base.eqString"-    | [PrimVal _ _ _ [Lit (StringLiteral s1)]-      ,PrimVal _ _ _ [Lit (StringLiteral s2)]+    | [PrimVal _ _ [Lit (StringLiteral s1)]+      ,PrimVal _ _ [Lit (StringLiteral s2)]       ] <- args     -> reduce (boolToBoolLiteral tcm ty (s1 == s2))     | otherwise -> error (show args)@@ -1253,15 +1330,21 @@    "Clash.Class.BitPack.packDouble#" -- :: Double -> BitVector 64     | [DC _ [Left arg]] <- args-    , (h2,[],Literal (DoubleLiteral i)) <- whnf reduceConstant tcm True (h,[],arg)+    , mach2@Machine{mStack=[],mTerm=Literal (DoubleLiteral i)} <- whnf tcm True (setTerm arg $ stackClear mach)     -> let resTyInfo = extractTySizeInfo tcm ty tys-       in  Just (h2,k,mkBitVectorLit' resTyInfo 0 (BitVector.unsafeToInteger $ (pack :: Double -> BitVector 64) $ fromRational i))+        in Just $ mach2+             { mStack = mStack mach+             , mTerm = mkBitVectorLit' resTyInfo 0 (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 tcm True (h,[],arg)+    , mach2@Machine{mStack=[],mTerm=Literal (FloatLiteral i)} <- whnf tcm True (setTerm arg $ stackClear mach)     -> let resTyInfo = extractTySizeInfo tcm ty tys-       in  Just (h2,k,mkBitVectorLit' resTyInfo 0 (BitVector.unsafeToInteger $ (pack :: Float -> BitVector 32) $ fromRational i))+        in Just $ mach2+             { mStack = mStack mach+             , mTerm = mkBitVectorLit' resTyInfo 0 (BitVector.unsafeToInteger $ (pack :: Float -> BitVector 32) $ fromRational i)+             }    "Clash.Class.BitPack.unpackFloat#"     | [i] <- bitVectorLiterals' args@@ -1380,6 +1463,12 @@   "Clash.Sized.Internal.BitVector.low"     -> reduce (mkBitLit ty 0 0) +  "Clash.Sized.Internal.BitVector.undefined#"+    | Just (_, kn) <- extractKnownNat tcm tys+    -> let resTyInfo = extractTySizeInfo tcm ty tys+           mask = bit (fromInteger kn) - 1+       in reduce (mkBitVectorLit' resTyInfo mask 0)+ -- Eq   "Clash.Sized.Internal.BitVector.eq##" | [(0,i),(0,j)] <- bitLiterals args     -> reduce (boolToBoolLiteral tcm ty (i == j))@@ -1398,18 +1487,22 @@  -- Bits   "Clash.Sized.Internal.BitVector.and##"-    | [(0,i),(0,j)] <- bitLiterals args-    -> reduce (mkBitLit ty 0 (i .&. j))+    | [i,j] <- bitLiterals args+    -> let Bit msk val = BitVector.and## (toBit i) (toBit j)+       in reduce (mkBitLit ty msk val)   "Clash.Sized.Internal.BitVector.or##"-    | [(0,i),(0,j)] <- bitLiterals args-    -> reduce (mkBitLit ty 0 (i .|. j))+    | [i,j] <- bitLiterals args+    -> let Bit msk val = BitVector.or## (toBit i) (toBit j)+       in reduce (mkBitLit ty msk val)   "Clash.Sized.Internal.BitVector.xor##"-    | [(0,i),(0,j)] <- bitLiterals args-    -> reduce (mkBitLit ty 0 (i `xor` j))+    | [i,j] <- bitLiterals args+    -> let Bit msk val = BitVector.xor## (toBit i) (toBit j)+       in reduce (mkBitLit ty msk val)    "Clash.Sized.Internal.BitVector.complement##"-    | [(0,i)] <- bitLiterals args-    -> reduce (mkBitLit ty 0 (complement i))+    | [i] <- bitLiterals args+    -> let Bit msk val = BitVector.complement## (toBit i)+       in reduce (mkBitLit ty msk val)  -- Pack   "Clash.Sized.Internal.BitVector.pack#"@@ -1473,12 +1566,12 @@   "Clash.Sized.Internal.BitVector.replaceBit#" -- :: :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n     | Just (_, n) <- extractKnownNat tcm tys     , [ _-      , PrimVal bvNm _ _ [_, Lit (IntegerLiteral mskBv), Lit (IntegerLiteral bv)]+      , PrimVal bvP _ [_, Lit (IntegerLiteral mskBv), Lit (IntegerLiteral bv)]       , valArgs -> Just [Literal (IntLiteral i)]-      , PrimVal bNm  _ _ [Lit (IntegerLiteral mskB), Lit (IntegerLiteral b)]+      , PrimVal bP _ [Lit (IntegerLiteral mskB), Lit (IntegerLiteral b)]       ] <- args-    , bvNm == "Clash.Sized.Internal.BitVector.fromInteger#"-    , bNm  == "Clash.Sized.Internal.BitVector.fromInteger##"+    , primName bvP == "Clash.Sized.Internal.BitVector.fromInteger#"+    , primName bP  == "Clash.Sized.Internal.BitVector.fromInteger##"       -> let resTyInfo = extractTySizeInfo tcm ty tys              (mskVal,val) = reifyNat n (op (BV mskBv bv) (fromInteger i) (Bit mskB b))       in reduce (mkBitVectorLit' resTyInfo mskVal val)@@ -1818,8 +1911,8 @@     , Just (i,j) <- indexLiterals args     -> reduce $ catchDivByZero (mkIndexLit ty nTy kn (i `rem` j))   "Clash.Sized.Internal.Index.toInteger#"-    | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args-    , nm' == "Clash.Sized.Internal.Index.fromInteger#"+    | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+    , primName p == "Clash.Sized.Internal.Index.fromInteger#"     -> reduce (integerToIntegerLiteral i)  -- Resize@@ -1955,8 +2048,8 @@     , Just val <- reifyNat kn (liftSigned2 (Signed.mod#) ty tcm tys args)     -> reduce $ catchDivByZero val   "Clash.Sized.Internal.Signed.toInteger#"-    | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args-    , nm' == "Clash.Sized.Internal.Signed.fromInteger#"+    | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+    , primName p == "Clash.Sized.Internal.Signed.fromInteger#"     -> reduce (integerToIntegerLiteral i)  -- Bits@@ -2146,8 +2239,8 @@     , Just val <- reifyNat kn (liftUnsigned2 (Unsigned.rem#) ty tcm tys args)     -> reduce $ catchDivByZero val   "Clash.Sized.Internal.Unsigned.toInteger#"-    | [PrimVal nm' _ _ [_, Lit (IntegerLiteral i)]] <- args-    , nm' == "Clash.Sized.Internal.Unsigned.fromInteger#"+    | [PrimVal p _ [_, Lit (IntegerLiteral i)]] <- args+    , primName p == "Clash.Sized.Internal.Unsigned.fromInteger#"     -> reduce (integerToIntegerLiteral i)  -- Bits@@ -2260,7 +2353,7 @@                          ,Left (mkApps (Data snatDc)                                        [Right k'ty                                        ,Left (Literal (NaturalLiteral (k'-1)))])-                         ,Left (mkApps (Prim nm pInfo)+                         ,Left (mkApps (Prim pInfo)                                        [Right pTy                                        ,Right k'ty                                        ,Right aTy@@ -2270,7 +2363,7 @@                                        ,Left (valToTerm g)                                        ,Left (Either.lefts tArgs !! 1)                                        ])-                         ,Left (mkApps (Prim nm pInfo)+                         ,Left (mkApps (Prim pInfo)                                        [Right pTy                                        ,Right k'ty                                        ,Right aTy@@ -2326,7 +2419,7 @@                       if i' == 0                          then reduceWHNF (Either.lefts vArgs !! 1)                          else reduceWHNF $-                              mkApps (Prim nm pInfo)+                              mkApps (Prim pInfo)                                      [Right (LitTy (NumTy (n'-1)))                                      ,Right aTy                                      ,Left (Literal (NaturalLiteral (n'-1)))@@ -2348,7 +2441,7 @@     -> if n == 0           then reduceWHNF (Either.lefts vArgs !! 1)           else reduceWHNF-                (mkApps (Prim nm pInfo)+                (mkApps (Prim pInfo)                                      [Right (LitTy (NumTy (n-1)))                                      ,Right aTy                                      ,Left (Either.lefts vArgs !! 2)@@ -2368,7 +2461,7 @@           else reduce $                mkVecCons consCon aTy n                   (Either.lefts vArgs !! 1)-                  (mkApps (Prim nm pInfo)+                  (mkApps (Prim pInfo)                                        [Right (LitTy (NumTy (n-1)))                                        ,Right aTy                                        ,Left (Either.lefts vArgs !! 2)])@@ -2403,7 +2496,7 @@                    iAlt   = (tupPat, (Var iId))                in  reduce $                    mkVecCons consCon aTy n' (Either.lefts vArgs !! 1) $-                   mkApps (Prim nm pInfo)+                   mkApps (Prim pInfo)                           [Right (LitTy (NumTy (i'-s')))                           ,Right sTy                           ,Right (LitTy (NumTy (n'-1)))@@ -2433,7 +2526,7 @@                    tupPat = DataPat tupDc [] [fId,iId]                    iAlt   = (tupPat, (Var iId))                in  reduceWHNF $-                   mkApps (Prim nm pInfo)+                   mkApps (Prim pInfo)                      [Right iTy                      ,Right sTy                      ,Right nTy@@ -2470,7 +2563,7 @@            [nilCon,consCon]   = tyConDataCons vecTc            -- Recursive call to @splitAt@            splitAtRec v =-            mkApps (Prim nm pInfo)+            mkApps (Prim pInfo)                    [Right (LitTy (NumTy (m-1)))                    ,Right nTy                    ,Right aTy@@ -2552,7 +2645,7 @@          _ -> reduce $               mkVecCons consCon mVecTy n                 (Case splitAtCall mVecTy [asAlt])-                (mkApps (Prim nm pInfo)+                (mkApps (Prim pInfo)                     [Right (LitTy (NumTy (n-1)))                     ,Right mTy                     ,Right aTy@@ -2585,7 +2678,7 @@             -> -- x : (xs ++ ys)                reduce $                mkVecCons dc aTy (n' + m) (Either.lefts vArgs !! 1)-                 (mkApps (Prim nm pInfo)+                 (mkApps (Prim pInfo)                                       [Right (LitTy (NumTy (n'-1)))                                       ,Right aTy                                       ,Right mTy@@ -2610,7 +2703,7 @@                     ,Right $ mkTyConApp typeNatMul                       [mkTyConApp typeNatSub [nTy,LitTy (NumTy 1)], mTy]                     ,Left h'-                    ,Left $ mkApps (Prim nm pInfo)+                    ,Left $ mkApps (Prim pInfo)                       [ Right (LitTy (NumTy (n-1)))                       , Right mTy                       , Right aTy@@ -2634,7 +2727,7 @@                          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 pInfo)+                                (mkApps (Prim pInfo)                                         [Right (LitTy (NumTy (n'-1)))                                         ,Right aTy                                         ,Left (Literal (NaturalLiteral (n'-1)))@@ -2668,7 +2761,7 @@                 [Right (LitTy (NumTy (n-1)))                 ,Right aTy                 ,Right (LitTy (NumTy 1))-                ,Left (mkApps (Prim nm pInfo)+                ,Left (mkApps (Prim pInfo)                               [Right (LitTy (NumTy (n-1)))                               ,Right aTy                               ,Left (Either.lefts vArgs !! 2)@@ -2707,7 +2800,7 @@                                        ,Left (primCo consCoTy)                                        ])                        , Left  (Either.lefts vArgs !! 1)-                       , Left  (mkApps (Prim nm pInfo)+                       , Left  (mkApps (Prim pInfo)                                        [ Right nTy                                        , Right (LitTy (NumTy (m'-1)))                                        , Right aTy@@ -2715,6 +2808,7 @@                                        , Left  (Either.lefts vArgs !! 2)                                        ])                        ]+   "Clash.Sized.Vector.rotateLeftS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a     | nTy : aTy : _ : _ <- tys     , kn : xs : d : _ <- args@@ -2723,14 +2817,14 @@     -> case n of          0  -> reduce (mkVecNil dc aTy)          n' | DC snatDc [_,Left d'] <- d-            , (h2,[],Literal (NaturalLiteral d2)) <- whnf reduceConstant tcm isSubj (h,[],d')+            , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf tcm isSubj (setTerm d' $ stackClear mach)             -> case (d2 `mod` n) of                  0  -> reduce (valToTerm xs)                  d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty                            (Just vecTc)     = lookupUniqMap vecTcNm tcm                            [nilCon,consCon] = tyConDataCons vecTc-                       in  reduceWHNF' h2 $-                           mkApps (Prim nm pInfo)+                       in  reduceWHNF' mach2 $+                           mkApps (Prim pInfo)                                   [Right nTy                                   ,Right aTy                                   ,Right (LitTy (NumTy (d3-1)))@@ -2746,6 +2840,7 @@                                                 ,Left  (Literal (NaturalLiteral (d3-1)))])                                   ]          _  -> Nothing+   "Clash.Sized.Vector.rotateRightS" -- :: KnownNat n => Vec n a -> SNat d -> Vec n a     | isSubj     , nTy : aTy : _ : _ <- tys@@ -2755,12 +2850,12 @@     -> case n of          0  -> reduce (mkVecNil dc aTy)          n' | DC snatDc [_,Left d'] <- d-            , (h2,[],Literal (NaturalLiteral d2)) <- whnf reduceConstant tcm isSubj (h,[],d')+            , mach2@Machine{mStack=[],mTerm=Literal (NaturalLiteral d2)} <- whnf tcm isSubj (setTerm d' $ stackClear mach)             -> case (d2 `mod` n) of                  0  -> reduce (valToTerm xs)                  d3 -> let (_,tyView -> TyConApp vecTcNm _) = splitFunForallTy ty-                       in  reduceWHNF' h2 $-                           mkApps (Prim nm pInfo)+                       in  reduceWHNF' mach2 $+                           mkApps (Prim pInfo)                                   [Right nTy                                   ,Right aTy                                   ,Right (LitTy (NumTy (d3-1)))@@ -2791,7 +2886,7 @@          n' -> reduce $                mkVecCons dc bTy n'                  (mkApps (valToTerm (args !! 0)) [Left (Either.lefts vArgs !! 1)])-                 (mkApps (Prim nm pInfo)+                 (mkApps (Prim pInfo)                                       [Right aTy                                       ,Right bTy                                       ,Right (LitTy (NumTy (n' - 1)))@@ -2806,8 +2901,7 @@     , Right n <- runExcept (tyNatSize tcm nTy)     , let iLit = mkIndexLit (Either.rights tyArgs' !! 0) nTy n 0     -> reduceWHNF $-       mkApps (Prim "Clash.Sized.Vector.imap_go"-                    (PrimInfo (vecImapGoTy vecTcNm indexTcNm) WorkNever))+       mkApps (Prim (PrimInfo "Clash.Sized.Vector.imap_go" (vecImapGoTy vecTcNm indexTcNm) WorkNever))               [Right nTy               ,Right nTy               ,Right aTy@@ -2831,13 +2925,12 @@                    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 pInfo)+                 (mkApps (Prim pInfo)                          [Right nTy                          ,Right (LitTy (NumTy (m'-1)))                          ,Right aTy                          ,Right bTy-                         ,Left (mkApps (Prim "Clash.Sized.Internal.Index.+#"-                                             (PrimInfo (indexAddTy indexTcNm) WorkVariable))+                         ,Left (mkApps (Prim (PrimInfo "Clash.Sized.Internal.Index.+#" (indexAddTy indexTcNm) WorkVariable))                                        [Right nTy                                        ,Left (Literal (NaturalLiteral n'))                                        ,Left (valToTerm n)@@ -2866,7 +2959,7 @@                                     ,Left  (valToTerm ys)                                     ])                             ])-                 (mkApps (Prim nm pInfo)+                 (mkApps (Prim pInfo)                                       [Right aTy                                       ,Right bTy                                       ,Right cTy@@ -2891,7 +2984,7 @@          _ -> reduceWHNF $               mkApps (valToTerm f)                      [Left (Either.lefts vArgs !! 1)-                     ,Left (mkApps (Prim nm pInfo)+                     ,Left (mkApps (Prim pInfo)                                    [Right aTy                                    ,Right bTy                                    ,Right (LitTy (NumTy (n-1)))@@ -2921,8 +3014,7 @@                   n1mTy  = LitTy (NumTy n1)                   n1m'ty = LitTy (NumTy (n1-1))                   splitAtCall =-                   mkApps (Prim "Clash.Sized.Vector.fold_split"-                                (PrimInfo (foldSplitAtTy vecTcNm) WorkNever))+                   mkApps (Prim (PrimInfo "Clash.Sized.Vector.fold_split" (foldSplitAtTy vecTcNm) WorkNever))                           [Right mTy                           ,Right n1mTy                           ,Right aTy@@ -2941,13 +3033,13 @@                   bsAlt    = (tupPat, (Var bsId))               in  reduceWHNF $                   mkApps (valToTerm f)-                         [Left (mkApps (Prim nm pInfo)+                         [Left (mkApps (Prim pInfo)                                        [Right aTy                                        ,Right m'ty                                        ,Left (valToTerm f)                                        ,Left (Case splitAtCall mVecTy [asAlt])                                        ])-                         ,Left (mkApps (Prim nm pInfo)+                         ,Left (mkApps (Prim pInfo)                                        [Right aTy                                        ,Right n1m'ty                                        ,Left  (valToTerm f)@@ -2971,7 +3063,7 @@            [nilCon,consCon]   = tyConDataCons vecTc            -- Recursive call to @splitAt@            splitAtRec v =-            mkApps (Prim nm pInfo)+            mkApps (Prim pInfo)                    [Right (LitTy (NumTy (m-1)))                    ,Right nTy                    ,Right aTy@@ -3031,7 +3123,7 @@                                        [Right k'ty                                        ,Left (Literal (NaturalLiteral (k'-1)))])                          ,Left (Either.lefts vArgs !! 1)-                         ,Left (mkApps (Prim nm pInfo)+                         ,Left (mkApps (Prim pInfo)                                        [Right pTy                                        ,Right k'ty                                        ,Right aTy@@ -3086,7 +3178,7 @@                          ,Left (mkApps (Data snatDc)                                        [Right k'ty                                        ,Left (Literal (NaturalLiteral (k'-1)))])-                         ,Left (mkApps (Prim nm pInfo)+                         ,Left (mkApps (Prim pInfo)                                        [Right pTy                                        ,Right k'ty                                        ,Right aTy@@ -3095,7 +3187,7 @@                                        ,Left (valToTerm f)                                        ,Left (valToTerm g)                                        ,Left (Case splitAtCall xsSVecTy [asAlt])])-                         ,Left (mkApps (Prim nm pInfo)+                         ,Left (mkApps (Prim pInfo)                                        [Right pTy                                        ,Right k'ty                                        ,Right aTy@@ -3124,7 +3216,7 @@                              , Right aTy                              , Left  (valToTerm xs)                              ])-                     (mkApps (Prim nm pInfo)+                     (mkApps (Prim pInfo)                              [ Right (LitTy (NumTy (n' - 1)))                              , Right aTy                              , Left  (Literal (NaturalLiteral (n'-1)))@@ -3143,7 +3235,7 @@     , Right n <- runExcept (tyNatSize tcm nTy)     -> case n of          0 -> let (pureF,ids') = runPEM (mkSelectorCase $(curLoc) is0 tcm (valToTerm apDict) 1 1) ids-              in  reduceWHNF' (Heap gh gbl h' ids' is0) $+              in  reduceWHNF' (mach { mSupply = ids' }) $                   mkApps pureF                          [Right (mkTyConApp (vecTcNm) [nTy,bTy])                          ,Left  (mkVecNil dc bTy)]@@ -3154,7 +3246,7 @@                     return (fmapF',apF')                   n'ty = LitTy (NumTy (n-1))                   Just (consCoTy : _) = dataConInstArgTys dc [nTy,bTy,n'ty]-              in  reduceWHNF' (Heap gh gbl h' ids' is0) $+              in  reduceWHNF' (mach { mSupply = ids' }) $                   mkApps apF                          [Right (mkTyConApp vecTcNm [n'ty,bTy])                          ,Right (mkTyConApp vecTcNm [nTy,bTy])@@ -3170,7 +3262,7 @@                                        ,Left (mkApps (valToTerm f)                                                      [Left (Either.lefts vArgs !! 1)])                                        ])-                         ,Left (mkApps (Prim nm pInfo)+                         ,Left (mkApps (Prim pInfo)                                        [Right aTy                                        ,Right fTy                                        ,Right bTy@@ -3183,7 +3275,7 @@     where       (tyArgs,_)         = splitFunForallTy ty       TyConApp vecTcNm _ = tyView (Either.rights tyArgs !! 2)-      Heap gh gbl h' ids is0 = h+      (ids, is0) = (mSupply mach, mScopeNames mach)  -- BitPack   "Clash.Sized.Vector.concatBitVector#"@@ -3203,7 +3295,7 @@                  , Right mTy                  , Left (Literal (NaturalLiteral ((n'-1)*m)))                  , Left (Either.lefts vArgs !! 1)-                 , Left (mkApps (Prim nm pInfo)+                 , Left (mkApps (Prim pInfo)                                 [ Right (LitTy (NumTy (n'-1)))                                 , Right mTy                                 , Left (Literal (NaturalLiteral (n'-1)))@@ -3253,7 +3345,7 @@            in  reduce $ mkVecCons consCon (mkTyConApp bvTcNm [mTy]) n'                 (Case splitCall mBVTy [xAlt])-                (mkApps (Prim nm pInfo)+                (mkApps (Prim pInfo)                         [ Right (LitTy (NumTy (n'-1)))                         , Right mTy                         , Left (Literal (NaturalLiteral (n'-1)))@@ -3287,15 +3379,19 @@       else         f (map fromInteger natsAsInts) -    reduce :: Term -> Maybe (Heap, Stack, Term)+    reduce :: Term -> Maybe Machine     reduce e = case isX e of-      Left msg -> trace (unlines ["Warning: Not evaluating constant expression:", show nm, "Because doing so generates an XException:", msg]) Nothing-      Right e' -> Just (h,k,e')-    reduceWHNF e = let (h2,[],e') = whnf reduceConstant tcm isSubj (h,[],e)-                   in  Just (h2,k,e')-    reduceWHNF' h' e = let (h2,[],e') = whnf reduceConstant tcm isSubj (h',[],e)-                       in  Just (h2,k,e')+      Left msg -> trace (unlines ["Warning: Not evaluating constant expression:", show (primName pInfo), "Because doing so generates an XException:", msg]) Nothing+      Right e' -> Just (setTerm e' mach) +    reduceWHNF e =+      let mach1@Machine{mStack=[]} = whnf tcm isSubj (setTerm e $ stackClear mach)+      in Just $ mach1 { mStack = mStack mach }++    reduceWHNF' mach1 e =+      let mach2@Machine{mStack=[]} = whnf tcm isSubj (setTerm e mach1)+       in Just $ mach2 { mStack = mStack mach }+     makeUndefinedIf :: Exception e => (e -> Bool) -> Term -> Term     makeUndefinedIf wantToHandle tm =       case unsafeDupablePerformIO $ tryJust selectException (evaluate $ force tm) of@@ -3306,129 +3402,149 @@         selectException e | wantToHandle e = Just e                           | otherwise = Nothing         msg e = unlines ["Warning: caught exception: \"" ++ show e ++ "\" while trying to evaluate: "-                        , showPpr (mkApps (Prim nm pInfo) (map (Left . valToTerm) args))+                        , showPpr (mkApps (Prim pInfo) (map (Left . valToTerm) args))                         ]      catchDivByZero = makeUndefinedIf (==DivideByZero) -typedLiterals' :: (Value -> Maybe a) -> [Value] -> [a]-typedLiterals' typedLiteral = mapMaybe typedLiteral+-- Helper functions for literals +pairOf :: (Value -> Maybe a) -> [Value] -> Maybe (a, a)+pairOf f [x, y] = (,) <$> f x <*> f y+pairOf _ _ = Nothing++listOf :: (Value -> Maybe a) -> [Value] -> [a]+listOf = mapMaybe++wrapUnsigned :: Integer -> Integer -> Integer+wrapUnsigned n i = i `mod` sz+ where+  sz = 1 `shiftL` fromInteger n++wrapSigned :: Integer -> Integer -> Integer+wrapSigned n i = if mask == 0 then 0 else res+ where+  mask = 1 `shiftL` fromInteger (n - 1)+  res  = case divMod i mask of+           (s,i1) | even s    -> i1+                  | otherwise -> i1 - mask+ doubleLiterals' :: [Value] -> [Rational]-doubleLiterals' = typedLiterals' doubleLiteral-  where-    doubleLiteral x = case x of-      Lit (DoubleLiteral i) -> Just i-      _ -> Nothing+doubleLiterals' = listOf doubleLiteral +doubleLiteral :: Value -> Maybe Rational+doubleLiteral v = case v 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+floatLiterals' = listOf floatLiteral -integerLiterals :: [Value] -> Maybe (Integer, Integer)-integerLiterals args = case integerLiterals' args of-  [i,j] -> Just (i,j)+floatLiteral :: Value -> Maybe Rational+floatLiteral v = case v of+  Lit (FloatLiteral i) -> Just i   _ -> Nothing +integerLiterals :: [Value] -> Maybe (Integer, Integer)+integerLiterals = pairOf integerLiteral++integerLiteral :: Value -> Maybe Integer+integerLiteral v =+  case v of+    Lit (IntegerLiteral i) -> Just i+    DC dc [Left (Literal (IntLiteral i))]+      | dcTag dc == 1+      -> Just i+    DC dc [Left (Literal (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))))]+      | dcTag dc == 2+      -> Just (Jp# (BN# ba))+      | dcTag dc == 3+      -> Just (Jn# (BN# ba))+    _ -> Nothing+ naturalLiterals :: [Value] -> Maybe (Integer, Integer)-naturalLiterals args = case naturalLiterals' args of-  [i,j] -> Just (i, j)-  _ -> Nothing+naturalLiterals = pairOf naturalLiteral +naturalLiteral :: Value -> Maybe Integer+naturalLiteral v =+  case v of+    Lit (NaturalLiteral i) -> Just i+    DC dc [Left (Literal (WordLiteral i))]+      | dcTag dc == 1+      -> Just i+    DC dc [Left (Literal (ByteArrayLiteral (Vector.Vector _ _ (ByteArray.ByteArray ba))))]+      | dcTag dc == 2+      -> Just (Jp# (BN# ba))+    _ -> Nothing+ integerLiterals' :: [Value] -> [Integer]-integerLiterals' = typedLiterals' integerLiteral+integerLiterals' = listOf integerLiteral  naturalLiterals' :: [Value] -> [Integer]-naturalLiterals' = typedLiterals' naturalLiteral+naturalLiterals' = listOf naturalLiteral  intLiterals :: [Value] -> Maybe (Integer,Integer)-intLiterals args = case args of-  [Lit (IntLiteral i), Lit (IntLiteral j)] -> Just (i,j)-  _ -> Nothing+intLiterals = pairOf intLiteral  intLiterals' :: [Value] -> [Integer]-intLiterals' = typedLiterals' intLiteral-  where-    intLiteral x = case x of-      Lit (IntLiteral i) -> Just i-      _ -> Nothing+intLiterals' = listOf intLiteral +intLiteral :: Value -> Maybe Integer+intLiteral x = case x of+  Lit (IntLiteral i) -> Just i+  _ -> Nothing+ intCLiteral :: Value -> Maybe Integer-intCLiteral (DC _ [Left (Literal (IntLiteral i))]) = Just i-intCLiteral _                                      = Nothing+intCLiteral v = case v of+  (DC _ [Left (Literal (IntLiteral i))]) -> Just i+  _ -> Nothing  intCLiterals :: [Value] -> Maybe (Integer, Integer)-intCLiterals (a1:a2:_) = liftA2 (,) (intCLiteral a1) (intCLiteral a2)-intCLiterals _         = Nothing+intCLiterals = pairOf intCLiteral -intCLiterals' :: [Value] -> [Integer]-intCLiterals' = catMaybes . map intCLiteral+wordLiterals :: [Value] -> Maybe (Integer,Integer)+wordLiterals = pairOf wordLiteral -mkIntCLiteral-  :: HasCallStack-  => Value-  -- ^ Some existing intC literal. To construct a new intC literal, this-  -- function needs the dataconstructor.-  -> Integer-  -- ^ New value of intC literal-  -> Term-mkIntCLiteral (DC dc [Left (Literal (IntLiteral _))]) i =-  App (Data dc) (Literal (IntLiteral i))-mkIntCLiteral v _i =-  error $ "Report as bug: mkIntCLiteral was called with wrong value: " ++ show v+wordLiterals' :: [Value] -> [Integer]+wordLiterals' = listOf wordLiteral -wordLiterals :: [Value] -> Maybe (Integer,Integer)-wordLiterals args = case args of-  [Lit (WordLiteral i), Lit (WordLiteral j)] -> Just (i,j)+wordLiteral :: Value -> Maybe Integer+wordLiteral x = case x of+  Lit (WordLiteral i) -> Just i   _ -> 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 = pairOf charLiteral  charLiterals' :: [Value] -> [Char]-charLiterals' = typedLiterals' charLiteral-  where-    charLiteral x = case x of-      Lit (CharLiteral c) -> Just c-      _ -> Nothing+charLiterals' = listOf charLiteral +charLiteral :: Value -> Maybe Char+charLiteral x = case x of+  Lit (CharLiteral c) -> Just c+  _ -> Nothing+ sizedLiterals :: Text -> [Value] -> Maybe (Integer,Integer)-sizedLiterals szCon args-  = case args of-      ([ PrimVal nm  _ _ [_, Lit (IntegerLiteral i)]-       , PrimVal nm' _ _ [_, Lit (IntegerLiteral j)]])-        | nm  == szCon-        , nm' == szCon -> Just (i,j)-      _ -> Nothing+sizedLiterals szCon = pairOf (sizedLiteral szCon)  sizedLiterals' :: Text -> [Value] -> [Integer]-sizedLiterals' szCon = typedLiterals' (sizedLiteral szCon)+sizedLiterals' szCon = listOf (sizedLiteral szCon)  sizedLiteral :: Text -> Value -> Maybe Integer sizedLiteral szCon val = case val of-  PrimVal nm  _ _ [_, Lit (IntegerLiteral i)] | nm == szCon -> Just i+  PrimVal p _ [_, Lit (IntegerLiteral i)]+    | primName p == szCon -> Just i   _ -> Nothing  bitLiterals   :: [Value]   -> [(Integer,Integer)]-bitLiterals = map normalizeBit . typedLiterals' go+bitLiterals = map normalizeBit . mapMaybe go  where   normalizeBit (msk,v) = (msk .&. 1, v .&. 1)   go val = case val of-    PrimVal nm _ _ [Lit (IntegerLiteral m), Lit (IntegerLiteral i)]-      | nm == "Clash.Sized.Internal.BitVector.fromInteger##"+    PrimVal p _ [Lit (IntegerLiteral m), Lit (IntegerLiteral i)]+      | primName p == "Clash.Sized.Internal.BitVector.fromInteger##"       -> Just (m,i)     _ -> Nothing @@ -3438,45 +3554,43 @@ signedLiterals    = sizedLiterals "Clash.Sized.Internal.Signed.fromInteger#" unsignedLiterals  = sizedLiterals "Clash.Sized.Internal.Unsigned.fromInteger#" -bitVectorLiterals-  :: [Value] -> Maybe ((Integer,Integer),(Integer,Integer))-bitVectorLiterals args-  = case args of-      ([ PrimVal nm  _ _ [_, Lit (IntegerLiteral mi), Lit (IntegerLiteral i)]-       , PrimVal nm' _ _ [_, Lit (IntegerLiteral mj), Lit (IntegerLiteral j)]])-        | nm  == "Clash.Sized.Internal.BitVector.fromInteger#"-        , nm' == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just ((mi,i),(mj,j))-      _ -> Nothing- indexLiterals', signedLiterals', unsignedLiterals'   :: [Value] -> [Integer] indexLiterals'     = sizedLiterals' "Clash.Sized.Internal.Index.fromInteger#" signedLiterals'    = sizedLiterals' "Clash.Sized.Internal.Signed.fromInteger#" unsignedLiterals'  = sizedLiterals' "Clash.Sized.Internal.Unsigned.fromInteger#" +bitVectorLiterals+  :: [Value] -> Maybe ((Integer,Integer),(Integer,Integer))+bitVectorLiterals = pairOf bitVectorLiteral+ bitVectorLiterals'   :: [Value] -> [(Integer,Integer)]-bitVectorLiterals' = mapMaybe go- where-  go :: Value -> Maybe (Integer,Integer)-  go val = case val of-    PrimVal nm  _ _ [_, Lit (IntegerLiteral mi), Lit (IntegerLiteral i)]-      | nm == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just (mi, i)-    _ -> Nothing+bitVectorLiterals' = listOf bitVectorLiteral +bitVectorLiteral :: Value -> Maybe (Integer, Integer)+bitVectorLiteral val = case val of+  (PrimVal p _ [_, Lit (IntegerLiteral m), Lit (IntegerLiteral i)])+    | primName p == "Clash.Sized.Internal.BitVector.fromInteger#" -> Just (m, i)+  _ -> Nothing+ toBV :: (Integer,Integer) -> BitVector n toBV = uncurry BV  splitBV :: BitVector n -> (Integer,Integer) splitBV (BV msk val) = (msk,val) +toBit :: (Integer,Integer) -> Bit+toBit = uncurry Bit+ valArgs   :: Value   -> Maybe [Term]-valArgs (PrimVal _ _ _ vs) = Just (map valToTerm vs)-valArgs (DC _ args)        = Just (Either.lefts args)-valArgs _                  = Nothing-+valArgs v =+  case v of+    PrimVal _ _ vs -> Just (fmap valToTerm vs)+    DC _ args -> Just (Either.lefts args)+    _ -> Nothing  -- Tries to match literal arguments to a function like --   (Unsigned.shiftL#  :: forall n. KnownNat n => Unsigned n -> Int -> Unsigned n)@@ -3486,10 +3600,10 @@ sizedLitIntLit szCon tcm tys args   | Just (nTy,kn) <- extractKnownNat tcm tys   , [_-    ,PrimVal nm _ _ [_,Lit (IntegerLiteral i)]+    ,PrimVal p _ [_,Lit (IntegerLiteral i)]     ,valArgs -> Just [Literal (IntLiteral j)]     ] <- args-  , nm == szCon+  , primName p == szCon   = Just (nTy,kn,i,j)   | otherwise   = Nothing@@ -3506,10 +3620,10 @@ bitVectorLitIntLit tcm tys args   | Just (nTy,kn) <- extractKnownNat tcm tys   , [_-    ,PrimVal nm _ _ [_,Lit (IntegerLiteral m),Lit (IntegerLiteral i)]+    ,PrimVal p _ [_,Lit (IntegerLiteral m),Lit (IntegerLiteral i)]     ,valArgs -> Just [Literal (IntLiteral j)]     ] <- args-  , nm == "Clash.Sized.Internal.BitVector.fromInteger#"+  , primName p == "Clash.Sized.Internal.BitVector.fromInteger#"   = Just (nTy,kn,(m,i),j)   | otherwise   = Nothing@@ -3525,20 +3639,14 @@     -> Just (nTy, nInt)   _ -> Nothing -extractKnownNatVal :: TyConMap -> [Type] -> Maybe Integer-extractKnownNatVal tcm tys = fmap snd (extractKnownNat tcm tys)- -- From an argument list to function of type --   forall n m o .. . (KnownNat n, KnownNat m, KnownNat o, ..) => ... -- extract [(nTy,nInt), (mTy,mInt), (oTy,oInt)] -- where nTy is the Type of n -- and   nInt is its value as an Integer extractKnownNats :: TyConMap -> [Type] -> [(Type, Integer)]-extractKnownNats tcm tys =-  catMaybes (map (extractKnownNat tcm . pure)  tys)--extractKnownNatVals :: TyConMap -> [Type] -> [Integer]-extractKnownNatVals tcm tys = map snd (extractKnownNats tcm tys)+extractKnownNats tcm =+  mapMaybe (extractKnownNat tcm . pure)  -- Construct a constant term of a sized type mkSizedLit@@ -3644,26 +3752,6 @@ mkIndexLit rTy nTy kn val =   either id id (mkIndexLitE rTy nTy kn val) --- | Construct a constant term of a sized type-mkSizedLit'-  :: (Type -> Term)-  -- ^ Type constructor?-  -> (Type, Type, Integer)-  -- ^ (result type, forall n., KnownNat n)-  -> Integer-  -- ^ Value to construct-  -> Term-mkSizedLit' conPrim (ty,nTy,kn) = mkSizedLit conPrim ty nTy kn--mkSignedLit', mkUnsignedLit'-  :: (Type, Type, Integer)-  -- ^ (result type, forall n., KnownNat n)-  -> Integer-  -- ^ Value to construct-  -> Term-mkSignedLit'    = mkSizedLit' signedConPrim-mkUnsignedLit'  = mkSizedLit' unsignedConPrim- mkBitVectorLit'   :: (Type, Type, Integer)   -- ^ (result type, forall n., KnownNat n)@@ -3751,14 +3839,14 @@  bConPrim :: Type -> Term bConPrim (tyView -> TyConApp bTcNm _)-  = Prim "Clash.Sized.Internal.BitVector.fromInteger##" (PrimInfo funTy WorkNever)+  = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger##" funTy WorkNever)   where     funTy      = foldr1 mkFunTy [integerPrimTy,integerPrimTy,mkTyConApp bTcNm []] bConPrim _ = error $ $(curLoc) ++ "called with incorrect type"  bvConPrim :: Type -> Term bvConPrim (tyView -> TyConApp bvTcNm _)-  = Prim "Clash.Sized.Internal.BitVector.fromInteger#" (PrimInfo (ForAllTy nTV funTy) WorkNever)+  = Prim (PrimInfo "Clash.Sized.Internal.BitVector.fromInteger#" (ForAllTy nTV funTy) WorkNever)   where     funTy = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,integerPrimTy,mkTyConApp bvTcNm [nVar]]     nName = mkUnsafeSystemName "n" 0@@ -3768,7 +3856,7 @@  indexConPrim :: Type -> Term indexConPrim (tyView -> TyConApp indexTcNm _)-  = Prim "Clash.Sized.Internal.Index.fromInteger#" (PrimInfo (ForAllTy nTV funTy) WorkNever)+  = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" (ForAllTy nTV funTy) WorkNever)   where     funTy        = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp indexTcNm [nVar]]     nName      = mkUnsafeSystemName "n" 0@@ -3778,7 +3866,7 @@  signedConPrim :: Type -> Term signedConPrim (tyView -> TyConApp signedTcNm _)-  = Prim "Clash.Sized.Internal.Signed.fromInteger#" (PrimInfo (ForAllTy nTV funTy) WorkNever)+  = Prim (PrimInfo "Clash.Sized.Internal.Signed.fromInteger#" (ForAllTy nTV funTy) WorkNever)   where     funTy        = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp signedTcNm [nVar]]     nName      = mkUnsafeSystemName "n" 0@@ -3788,7 +3876,7 @@  unsignedConPrim :: Type -> Term unsignedConPrim (tyView -> TyConApp unsignedTcNm _)-  = Prim "Clash.Sized.Internal.Unsigned.fromInteger#" (PrimInfo (ForAllTy nTV funTy) WorkNever)+  = Prim (PrimInfo "Clash.Sized.Internal.Unsigned.fromInteger#" (ForAllTy nTV funTy) WorkNever)   where     funTy        = foldr1 mkFunTy [naturalPrimTy,integerPrimTy,mkTyConApp unsignedTcNm [nVar]]     nName        = mkUnsafeSystemName "n" 0@@ -3959,15 +4047,15 @@   :: TyConName   -- ^ Vec TyCon name   -> Term-vecHeadPrim vecTcNm = Prim "Clash.Sized.Vector.head"-                           (PrimInfo (vecHeadTy vecTcNm) WorkNever)+vecHeadPrim vecTcNm =+  Prim (PrimInfo "Clash.Sized.Vector.head" (vecHeadTy vecTcNm) WorkNever)  vecLastPrim   :: TyConName   -- ^ Vec TyCon name   -> Term-vecLastPrim vecTcNm = Prim "Clash.Sized.Vector.last"-                           (PrimInfo (vecHeadTy vecTcNm) WorkNever)+vecLastPrim vecTcNm =+  Prim (PrimInfo "Clash.Sized.Vector.last" (vecHeadTy vecTcNm) WorkNever)  vecHeadTy   :: TyConName@@ -3991,15 +4079,15 @@   :: TyConName   -- ^ Vec TyCon name   -> Term-vecTailPrim vecTcNm = Prim "Clash.Sized.Vector.tail"-                           (PrimInfo (vecTailTy vecTcNm) WorkNever)+vecTailPrim vecTcNm =+  Prim (PrimInfo "Clash.Sized.Vector.tail" (vecTailTy vecTcNm) WorkNever)  vecInitPrim   :: TyConName   -- ^ Vec TyCon name   -> Term-vecInitPrim vecTcNm = Prim "Clash.Sized.Vector.init"-                           (PrimInfo (vecTailTy vecTcNm) WorkNever)+vecInitPrim vecTcNm =+  Prim (PrimInfo "Clash.Sized.Vector.init" (vecTailTy vecTcNm) WorkNever)  vecTailTy   :: TyConName@@ -4028,8 +4116,7 @@   -- ^ Vec TyCon name   -> Term splitAtPrim snatTcNm vecTcNm =-  Prim "Clash.Sized.Vector.splitAt"-       (PrimInfo (splitAtTy snatTcNm vecTcNm) WorkNever)+  Prim (PrimInfo "Clash.Sized.Vector.splitAt" (splitAtTy snatTcNm vecTcNm) WorkNever)  splitAtTy   :: TyConName@@ -4095,8 +4182,8 @@   :: TyConName   -- ^ Vec TyCon name   -> Term-vecAppendPrim vecNm = Prim "Clash.Sized.Vector.++"-                           (PrimInfo (vecAppendTy vecNm) WorkNever)+vecAppendPrim vecNm =+  Prim (PrimInfo "Clash.Sized.Vector.++" (vecAppendTy vecNm) WorkNever)  vecAppendTy   :: TyConName@@ -4128,8 +4215,8 @@   :: TyConName   -- ^ Vec TyCon name   -> Term-vecZipWithPrim vecNm = Prim "Clash.Sized.Vector.zipWith"-                            (PrimInfo (vecAppendTy vecNm) WorkNever)+vecZipWithPrim vecNm =+  Prim (PrimInfo "Clash.Sized.Vector.zipWith" (vecZipWithTy vecNm) WorkNever)  vecZipWithTy   :: TyConName@@ -4200,8 +4287,8 @@   :: TyConName   -- ^ BitVector TyCon Name   -> Term-bvAppendPrim bvTcNm = Prim "Clash.Sized.Internal.BitVector.++#"-                           (PrimInfo (bvAppendTy bvTcNm) WorkNever)+bvAppendPrim bvTcNm =+  Prim (PrimInfo "Clash.Sized.Internal.BitVector.++#" (bvAppendTy bvTcNm) WorkNever)  bvAppendTy   :: TyConName@@ -4225,8 +4312,8 @@   :: TyConName   -- ^ BitVector TyCon Name   -> Term-bvSplitPrim bvTcNm = Prim "Clash.Sized.Internal.BitVector.split#"-                          (PrimInfo (bvSplitTy bvTcNm) WorkNever)+bvSplitPrim bvTcNm =+  Prim (PrimInfo "Clash.Sized.Internal.BitVector.split#" (bvSplitTy bvTcNm) WorkNever)  bvSplitTy   :: TyConName@@ -4278,3 +4365,7 @@  svoid :: (State# RealWorld -> State# RealWorld) -> IO () svoid m0 = IO (\s -> case m0 s of s' -> (# s', () #))++isTrueDC,isFalseDC :: DataCon -> Bool+isTrueDC dc  = dcUniq dc == getKey trueDataConKey+isFalseDC dc = dcUniq dc == getKey falseDataConKey