From 963982601717b51dc42fbbd1679242405548884e Mon Sep 17 00:00:00 2001 From: Martijn Bastiaan Date: Thu, 14 May 2026 20:36:34 +0200 Subject: [PATCH 01/17] Allow primitive YAML 'name' field to accept a list of names A primitive's 'name' field may now be either a single string (current syntax, fully backwards-compatible) or a non-empty list of strings: - Primitive: name: ["GHC.Num.Integer.IS", "GHC.Internal.Bignum.Integer.IS"] primType: Constructor workInfo: Never When a list is given, the same primitive body is registered in clash's PrimMap once per name. This is meant to handle wired-in GHC symbols whose host module changes across GHC versions (e.g. base 'GHC.Num.Integer.IS' on GHC <= 9.12 vs ghc-internal 'GHC.Internal.Bignum.Integer.IS' on GHC >= 9.14), without having to duplicate the entire YAML body in a sibling file. Implementation: a new newtype 'UnresolvedPrimitiveEntry' wraps a NonEmpty UnresolvedPrimitive and has the multi-name FromJSON instance. The loader ('resolvePrimitive') now decodes a list of entries and flattens them. The 'Primitive' record itself still carries a single 'name :: !Text', so every downstream lookup, hash, and error message is unchanged. The existing 'FromJSON UnresolvedPrimitive' instance is kept for backwards compatibility but rejects multi-name entries with a clear error message. --- clash-lib/src/Clash/Primitives/Types.hs | 97 +++++++++++++++++++------ clash-lib/src/Clash/Primitives/Util.hs | 13 +++- 2 files changed, 86 insertions(+), 24 deletions(-) diff --git a/clash-lib/src/Clash/Primitives/Types.hs b/clash-lib/src/Clash/Primitives/Types.hs index 6ddd7b56f6..7a86a0e429 100644 --- a/clash-lib/src/Clash/Primitives/Types.hs +++ b/clash-lib/src/Clash/Primitives/Types.hs @@ -26,6 +26,7 @@ module Clash.Primitives.Types , GuardedResolvedPrimitive , PrimMap , UnresolvedPrimitive + , UnresolvedPrimitiveEntry(..) , ResolvedPrimitive , ResolvedPrimMap , CompiledPrimitive @@ -41,7 +42,7 @@ import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) import Control.Monad (when) import Data.Aeson - (FromJSON (..), Value (..), (.:), (.:?), (.!=)) + (FromJSON (..), Object, Value (..), (.:), (.:?), (.!=)) import Data.Aeson.Types (Parser) import Data.Binary (Binary) import Data.Char (isUpper, isLower, isAlphaNum) @@ -49,6 +50,8 @@ import Data.Either (lefts) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as H import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) import qualified Data.Text as S import Data.Text.Lazy (Text) @@ -234,7 +237,40 @@ data Primitive a b c d } deriving (Show, Generic, NFData, Binary, Eq, Hashable, Functor) -instance FromJSON UnresolvedPrimitive where +-- | A single YAML/JSON primitive entry. Unlike 'UnresolvedPrimitive', this +-- newtype can represent multiple primitive records emitted from a single +-- YAML entry whose @name@ field is a list of names rather than a single +-- string. For example +-- +-- @ +-- - Primitive: +-- name: ["GHC.Num.Integer.IS", "GHC.Internal.Bignum.Integer.IS"] +-- primType: Constructor +-- workInfo: Never +-- @ +-- +-- yields two 'UnresolvedPrimitive's with the same body but different +-- names. This lets us register one primitive under multiple qualified +-- names without duplicating the YAML body — useful when GHC moves +-- wired-in symbols between modules across versions (e.g. 'GHC.Num.Integer' +-- on GHC <= 9.12 vs 'GHC.Internal.Bignum.Integer' on GHC >= 9.14). +-- +-- The single-string form @name: "foo"@ still parses; it produces a +-- 'NonEmpty' of length one. +newtype UnresolvedPrimitiveEntry = + UnresolvedPrimitiveEntry { unUnresolvedPrimitiveEntry :: NonEmpty UnresolvedPrimitive } + +-- | Read the @name@ field as either a single string or a non-empty list of +-- strings. +parseNames :: Object -> Parser (NonEmpty S.Text) +parseNames v = + (do n <- v .: "name"; pure (n :| [])) + <|> (do ns <- v .: "name" + case ns of + [] -> fail "[10] 'name' list must be non-empty" + x:xs -> pure (x :| xs)) + +instance FromJSON UnresolvedPrimitiveEntry where parseJSON (Object v) = case KeyMap.toList v of [(conKey,Object conVal)] -> @@ -250,7 +286,7 @@ instance FromJSON UnresolvedPrimitive where (Just _, Just _) -> fail "[8] Don't use both 'usedArguments' and 'ignoredArguments'" - name' <- conVal .: "name" + names <- parseNames conVal wf <- ((conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable) fName <- conVal .: "templateFunction" isMultiResult <- conVal .:? "multiResult" .!= False @@ -258,7 +294,8 @@ instance FromJSON UnresolvedPrimitive where <|> (Just . TFile <$> conVal .: "file") <|> (pure Nothing) fName' <- either fail return (parseBBFN fName) - return (BlackBoxHaskell name' wf args isMultiResult fName' templ) + pure $ UnresolvedPrimitiveEntry $ flip NE.map names $ \name' -> + BlackBoxHaskell name' wf args isMultiResult fName' templ "BlackBox" -> do outReg <- conVal .:? "outputReg" :: Parser (Maybe Bool) @@ -268,24 +305,28 @@ instance FromJSON UnresolvedPrimitive where , "Use 'outputUsage: Continuous|NonBlocking|Blocking' instead." ] - BlackBox <$> conVal .: "name" - <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable - <*> conVal .:? "renderVoid" .!= NoRenderVoid - <*> conVal .:? "multiResult" .!= False - <*> (conVal .: "kind" >>= parseTemplateKind) - <*> conVal .:? "warning" - <*> conVal .:? "outputUsage" .!= Cont - <*> conVal .:? "libraries" .!= [] - <*> conVal .:? "imports" .!= [] - <*> pure [] -- functionPlurality not supported in json - <*> (conVal .:? "includes" .!= [] >>= traverse parseInclude) - <*> (conVal .:? "resultName" >>= maybe (pure Nothing) parseResult) .!= [] - <*> (conVal .:? "resultInit" >>= maybe (pure Nothing) parseResult) .!= [] - <*> parseTemplate conVal - "Primitive" -> - Primitive <$> conVal .: "name" - <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable - <*> conVal .: "primType" + names <- parseNames conVal + wf <- (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable + rv <- conVal .:? "renderVoid" .!= NoRenderVoid + mr <- conVal .:? "multiResult" .!= False + k <- conVal .: "kind" >>= parseTemplateKind + w <- conVal .:? "warning" + ou <- conVal .:? "outputUsage" .!= Cont + ls <- conVal .:? "libraries" .!= [] + is <- conVal .:? "imports" .!= [] + inc <- conVal .:? "includes" .!= [] >>= traverse parseInclude + rn <- (conVal .:? "resultName" >>= maybe (pure Nothing) parseResult) .!= [] + ri <- (conVal .:? "resultInit" >>= maybe (pure Nothing) parseResult) .!= [] + tmpl <- parseTemplate conVal + -- functionPlurality not supported in json + pure $ UnresolvedPrimitiveEntry $ flip NE.map names $ \name' -> + BlackBox name' wf rv mr k w ou ls is [] inc rn ri tmpl + "Primitive" -> do + names <- parseNames conVal + wf <- (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable + ps <- conVal .: "primType" + pure $ UnresolvedPrimitiveEntry $ flip NE.map names $ \name' -> + Primitive name' wf ps e -> fail $ "[1] Expected: BlackBox or Primitive object, got: " ++ show e e -> fail $ "[2] Expected: BlackBox or Primitive object, got: " ++ show e @@ -331,3 +372,15 @@ instance FromJSON UnresolvedPrimitive where parseJSON unexpected = fail $ "[3] Expected: BlackBox or Primitive object, got: " ++ show unexpected + +-- | Backwards-compatible: parse a single 'UnresolvedPrimitive' from a YAML +-- entry. Fails if the entry's @name@ field is a list (use +-- 'UnresolvedPrimitiveEntry' instead). +instance FromJSON UnresolvedPrimitive where + parseJSON v = do + UnresolvedPrimitiveEntry ne <- parseJSON v + case ne of + p :| [] -> pure p + _ -> fail $ "[11] 'name' must be a single string when decoding to " + ++ "UnresolvedPrimitive; got a list. Decode to " + ++ "UnresolvedPrimitiveEntry to handle multi-name entries." diff --git a/clash-lib/src/Clash/Primitives/Util.hs b/clash-lib/src/Clash/Primitives/Util.hs index 2667b93ebe..c9f8901d08 100644 --- a/clash-lib/src/Clash/Primitives/Util.hs +++ b/clash-lib/src/Clash/Primitives/Util.hs @@ -47,10 +47,13 @@ import Clash.Annotations.Primitive , extractPrim, extractWarnings) import Clash.Core.Term (Term) import Clash.Core.Type (Type) +import qualified Data.List.NonEmpty as NE + import Clash.Primitives.Types ( Primitive(BlackBox), CompiledPrimitive, ResolvedPrimitive, ResolvedPrimMap , includes, template, TemplateSource(TFile, TInline), Primitive(..) - , UnresolvedPrimitive, CompiledPrimMap, GuardedResolvedPrimitive) + , UnresolvedPrimitive, UnresolvedPrimitiveEntry(..) + , CompiledPrimMap, GuardedResolvedPrimitive) import Clash.Netlist.Types (BlackBox(..), NetlistMonad) import Clash.Netlist.Util (preserveState) import Clash.Netlist.BlackBox.Util @@ -113,12 +116,18 @@ resolvePrimitive' metaPath (BlackBoxHaskell bbName wf usedArgs multiRes funcName -- | Interprets contents of json file as list of @Primitive@s. Throws -- exception if it fails. +-- +-- Each YAML/JSON entry may bind one or more @name@s (when the @name@ field +-- is a list), in which case a separate 'UnresolvedPrimitive' is produced +-- per name. See 'UnresolvedPrimitiveEntry'. resolvePrimitive :: HasCallStack => FilePath -> IO [(TS.Text, GuardedResolvedPrimitive)] resolvePrimitive fileName = do - prims <- decoder fileName <$> LZ.readFile fileName + entries <- (decoder fileName :: LZ.ByteString -> [UnresolvedPrimitiveEntry]) + <$> LZ.readFile fileName + let prims = concatMap (NE.toList . unUnresolvedPrimitiveEntry) entries mapM (resolvePrimitive' fileName) prims where decoder From 56fcd70b567fcfe34255ecaf6c1dd9c9efce7601 Mon Sep 17 00:00:00 2001 From: rowanG077 Date: Thu, 9 Apr 2026 14:17:20 +0200 Subject: [PATCH 02/17] Add source for GHC 9.14 executable --- clash-ghc/clash-ghc.cabal | 19 +- clash-ghc/src-bin-9.14/Clash/GHCi/Leak.hs | 88 + clash-ghc/src-bin-9.14/Clash/GHCi/UI.hs | 4973 +++++++++++++++++ .../src-bin-9.14/Clash/GHCi/UI/Exception.hs | 563 ++ clash-ghc/src-bin-9.14/Clash/GHCi/UI/Info.hs | 395 ++ clash-ghc/src-bin-9.14/Clash/GHCi/UI/Monad.hs | 547 ++ clash-ghc/src-bin-9.14/Clash/GHCi/UI/Print.hs | 92 + clash-ghc/src-bin-9.14/Clash/GHCi/Util.hs | 16 + clash-ghc/src-bin-9.14/Clash/Main.hs | 514 ++ .../src-bin-9.14/GHC/Driver/Session/Lint.hs | 124 + .../src-bin-9.14/GHC/Driver/Session/Mode.hs | 327 ++ 11 files changed, 7651 insertions(+), 7 deletions(-) create mode 100644 clash-ghc/src-bin-9.14/Clash/GHCi/Leak.hs create mode 100644 clash-ghc/src-bin-9.14/Clash/GHCi/UI.hs create mode 100644 clash-ghc/src-bin-9.14/Clash/GHCi/UI/Exception.hs create mode 100644 clash-ghc/src-bin-9.14/Clash/GHCi/UI/Info.hs create mode 100644 clash-ghc/src-bin-9.14/Clash/GHCi/UI/Monad.hs create mode 100644 clash-ghc/src-bin-9.14/Clash/GHCi/UI/Print.hs create mode 100644 clash-ghc/src-bin-9.14/Clash/GHCi/Util.hs create mode 100644 clash-ghc/src-bin-9.14/Clash/Main.hs create mode 100644 clash-ghc/src-bin-9.14/GHC/Driver/Session/Lint.hs create mode 100644 clash-ghc/src-bin-9.14/GHC/Driver/Session/Mode.hs diff --git a/clash-ghc/clash-ghc.cabal b/clash-ghc/clash-ghc.cabal index 77367d0a8c..3b829ae472 100644 --- a/clash-ghc/clash-ghc.cabal +++ b/clash-ghc/clash-ghc.cabal @@ -137,7 +137,9 @@ common common-options library import: common-options HS-Source-Dirs: src-ghc, src-bin-common - if impl(ghc >= 9.12.0) + if impl(ghc >= 9.14.0) + HS-Source-Dirs: src-bin-9.14 + elif impl(ghc >= 9.12.0) HS-Source-Dirs: src-bin-9.12 elif impl(ghc >= 9.10.2) HS-Source-Dirs: src-bin-9.10.2 @@ -179,17 +181,17 @@ library ghc-typelits-knownnat, ghc-typelits-natnormalise, deepseq >= 1.3.0.2 && < 1.6, - time >= 1.4.0.1 && < 1.15, - ghc >= 9.6.0 && < 9.13, - ghc-bignum >= 1.0 && < 1.4, - ghc-boot >= 9.6.0 && < 9.13, + time >= 1.4.0.1 && < 1.16, + ghc >= 9.6.0 && < 9.15, + ghc-bignum >= 1.0 && < 1.5, + ghc-boot >= 9.6.0 && < 9.15, ghc-prim >= 0.10 && < 0.14, - ghci >= 9.6.0 && < 9.13, + ghci >= 9.6.0 && < 9.15, uniplate >= 1.6.12 && < 1.8, reflection >= 2.1.2 && < 3.0, primitive >= 0.5.0.1 && < 1.0, string-interpolate ^>= 0.3, - template-haskell >= 2.8.0.0 && < 2.24, + template-haskell >= 2.8.0.0 && < 2.25, utf8-string >= 1.0.0.0 && < 1.1.0.0, vector >= 0.11 && < 1.0, exceptions >= 0.10.4 && < 0.11, @@ -238,3 +240,6 @@ library Other-Modules: Clash.GHCi.UI.Exception else Other-Modules: Clash.GHCi.UI.Tags + + if impl(ghc >= 9.14.0) + Other-Modules: Clash.GHCi.UI.Print diff --git a/clash-ghc/src-bin-9.14/Clash/GHCi/Leak.hs b/clash-ghc/src-bin-9.14/Clash/GHCi/Leak.hs new file mode 100644 index 0000000000..6a0b8b65d5 --- /dev/null +++ b/clash-ghc/src-bin-9.14/Clash/GHCi/Leak.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RecordWildCards, LambdaCase #-} +module GHCi.Leak + ( LeakIndicators + , getLeakIndicators + , checkLeakIndicators + ) where + +import Control.Monad +import Data.Bits +import Data.IORef +import Foreign.Ptr (ptrToIntPtr, intPtrToPtr) +import GHC +import GHC.Ptr (Ptr (..)) +import GHCi.Util +import GHC.Driver.Env +import GHC.Driver.Ppr +import GHC.Utils.Outputable +import GHC.Unit.Module.ModDetails +import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable +import GHC.Platform (target32Bit) +import GHC.Linker.Types +import Prelude +import System.Mem +import System.Mem.Weak +import GHC.Types.Unique.DFM +import Control.Exception + +-- Checking for space leaks in GHCi. See #15111, and the +-- -fghci-leak-check flag. + +data LeakIndicators = LeakIndicators [LeakModIndicators] + +data LeakModIndicators = LeakModIndicators + { leakMod :: Weak HomeModInfo + , leakIface :: Weak ModIface + , leakDetails :: Weak ModDetails + , leakLinkable :: [Maybe (Weak Linkable)] + } + +-- | Grab weak references to some of the data structures representing +-- the currently loaded modules. +getLeakIndicators :: HscEnv -> IO LeakIndicators +getLeakIndicators hsc_env = + fmap LeakIndicators $ do + hpt <- readIORef $ hptInternalTableRef $ hsc_HPT hsc_env + forM (eltsUDFM hpt) $ \hmi@HomeModInfo{..} -> do + leakMod <- mkWeakPtr hmi Nothing + leakIface <- mkWeakPtr hm_iface Nothing + leakDetails <- mkWeakPtr hm_details Nothing + leakLinkable <- mkWeakLinkables hm_linkable + return $ LeakModIndicators{..} + where + mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)] + mkWeakLinkables (HomeModLinkable mbc mo) = + mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo] + +-- | Look at the LeakIndicators collected by an earlier call to +-- `getLeakIndicators`, and print messasges if any of them are still +-- alive. +checkLeakIndicators :: DynFlags -> LeakIndicators -> IO () +checkLeakIndicators dflags (LeakIndicators leakmods) = do + performGC + forM_ leakmods $ \LeakModIndicators{..} -> do + deRefWeak leakMod >>= \case + Nothing -> return () + Just hmi -> + report ("HomeModInfo for " ++ + showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi) + deRefWeak leakIface >>= \case + Nothing -> return () + Just miface -> report ("ModIface:" ++ moduleNameString (moduleName (mi_module miface))) (Just miface) + deRefWeak leakDetails >>= report "ModDetails" + forM_ leakLinkable $ \l -> forM_ l $ \l' -> deRefWeak l' >>= report "Linkable" + where + report :: String -> Maybe a -> IO () + report _ Nothing = return () + report msg (Just a) = do + addr <- anyToPtr a + putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++ + show (maskTagBits addr)) + + tagBits + | target32Bit (targetPlatform dflags) = 2 + | otherwise = 3 + + maskTagBits :: Ptr a -> Ptr a + maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1)) diff --git a/clash-ghc/src-bin-9.14/Clash/GHCi/UI.hs b/clash-ghc/src-bin-9.14/Clash/GHCi/UI.hs new file mode 100644 index 0000000000..0243b5767d --- /dev/null +++ b/clash-ghc/src-bin-9.14/Clash/GHCi/UI.hs @@ -0,0 +1,4973 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +{-# OPTIONS -fno-warn-name-shadowing #-} +-- This module does a lot of it + +----------------------------------------------------------------------------- +-- +-- GHC Interactive User Interface +-- +-- (c) The GHC Team 2005-2006 +-- +----------------------------------------------------------------------------- + +module GHCi.UI ( + interactiveUI, + GhciSettings(..), + defaultGhciSettings, + ghciCommands, + ghciWelcomeMsg + ) where + +-- GHCi +import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' ) +import GHCi.UI.Monad hiding ( args, runStmt ) +import GHCi.UI.Info +import GHCi.UI.Exception hiding (GHCi) +import GHCi.Leak +import GHCi.UI.Print + +import GHC.Runtime.Debugger +import GHC.Runtime.Debugger.Breakpoints +import GHC.Runtime.Eval (mkTopLevEnv) +import GHC.Runtime.Eval.Utils + +-- The GHC interface +import GHC.ByteCode.Breakpoints (imodBreaks_modBreaks, InternalBreakpointId(..), getBreakSourceId, getBreakSourceMod) +import GHC.Runtime.Interpreter +import GHCi.RemoteTypes +import GHCi.BreakArray( breakOn, breakOff ) +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.PatSyn +import GHC.Driver.Flags +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Phases +import GHC.Driver.Session as DynFlags +import GHC.Driver.Ppr hiding (printForUser) +import GHC.Utils.Error hiding (traceCmd) +import GHC.Driver.Monad ( modifySession, modifySessionM ) +import GHC.Driver.Make ( newIfaceCache, ModIfaceCache(..) ) +import GHC.Driver.Config.Parser +import GHC.Driver.Config.Diagnostic +import qualified GHC +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), + Resume, SingleStep, Ghc, + GetDocsFailure(..), pushLogHookM, + getModuleGraph, handleSourceError, + BreakpointId(..) ) +import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation) +import GHC.Hs.ImpExp +import GHC.Hs +import GHC.Driver.Env +import GHC.Runtime.Context +import GHC.Types.TyThing +import GHC.Types.TyThing.Ppr +import GHC.Core.TyCo.Ppr +import GHC.Types.SafeHaskell ( getSafeMode ) +import GHC.Types.SourceError ( SourceError ) +import GHC.Types.Name +import GHC.Types.Var ( varType ) +import GHC.Iface.Syntax ( showToHeader ) +import GHC.Builtin.Names +import GHC.Builtin.Types( stringTyCon_RDR ) +import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName, greName, globalRdrEnvElts) +import GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Parser.Lexer as Lexer +import GHC.Parser.Header ( toArgs ) +import qualified GHC.Parser.Header as Header +import GHC.Types.PkgQual + +import GHC.Unit +import GHC.Unit.Finder as Finder +import GHC.Unit.Module.Graph (filterToposortToModules) +import GHC.Unit.Module.ModSummary + +import GHC.Data.StringBuffer +import GHC.Utils.Outputable +import GHC.Utils.Logger + +-- Other random utilities +import GHC.Types.Basic hiding ( isTopLevel ) +import GHC.Settings.Config +import GHC.Data.Graph.Directed +import GHC.Utils.Encoding +import GHC.Data.FastString +import qualified GHC.Linker.Loader as Loader +import GHC.Data.Maybe ( expectJust ) +import GHC.Types.Name.Set +import GHC.Utils.Panic hiding ( showException, try ) +import GHC.Utils.Misc +import qualified GHC.LanguageExtensions as LangExt +import qualified GHC.Data.Strict as Strict +import GHC.Types.Error +import qualified GHC.Unit.Home.Graph as HUG + +-- Haskell Libraries +import System.Console.Haskeline as Haskeline + +import Control.Applicative hiding (empty) +import Control.DeepSeq (deepseq) +import Control.Monad as Monad +import Control.Monad.Catch as MC +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except + +import Data.Array +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.Function +import qualified Data.Foldable as Foldable +import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) +import Data.List ( find, intercalate, intersperse, + isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as S +import Data.Maybe +import qualified Data.Map as M +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Time.LocalTime ( getZonedTime ) +import Data.Time.Format ( formatTime, defaultTimeLocale ) +import Data.Version ( showVersion ) +import qualified Data.Semigroup as S +import Prelude hiding ((<>)) + +import GHC.Utils.Exception as Exception hiding (catch, mask, handle) +import Foreign hiding (void) +import GHC.Stack hiding (SrcLoc(..)) +import GHC.Unit.Env +import GHC.Unit.Home.PackageTable + +import System.Directory +import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) +import System.FilePath +import System.Info +import System.IO +import System.IO.Error +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process +import Text.Printf +import Text.Read ( readMaybe ) +import Text.Read.Lex (isSymbolChar) + +import Unsafe.Coerce + +#if !defined(mingw32_HOST_OS) +import System.Posix hiding ( getEnv ) +#else +import qualified System.Win32 +#endif + +import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) +import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) + +import qualified GHC.Unit.Module.Graph as GHC + +----------------------------------------------------------------------------- + +data GhciSettings = GhciSettings { + availableCommands :: [Command], + fullHelpText :: String, + defPrompt :: PromptFunction, + defPromptCont :: PromptFunction + } + +defaultGhciSettings :: GhciSettings +defaultGhciSettings = + GhciSettings { + availableCommands = ghciCommands, + defPrompt = default_prompt, + defPromptCont = default_prompt_cont, + fullHelpText = defFullHelpText + } + +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": https://www.haskell.org/ghc/ :? for help" + +ghciCommands :: [Command] +ghciCommands = map mkCmd [ + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("?", keepGoing help, noCompletion), + ("add", keepGoingPaths addModule, completeFilename), + ("abandon", keepGoing abandonCmd, noCompletion), + ("break", keepGoing breakCmd, completeBreakpoint), + ("back", keepGoing backCmd, noCompletion), + ("browse", keepGoing' (browseCmd False), completeModule), + ("browse!", keepGoing' (browseCmd True), completeModule), + ("cd", keepGoing' changeDirectory, completeFilename), + ("continue", keepGoing' continueCmd, noCompletion), + ("cmd", keepGoing cmdCmd, completeExpression), + ("def", keepGoing (defineMacro False), completeExpression), + ("def!", keepGoing (defineMacro True), completeExpression), + ("delete", keepGoing deleteCmd, noCompletion), + ("disable", keepGoing disableCmd, noCompletion), + ("doc", keepGoing' docCmd, completeIdentifier), + ("edit", keepGoing' editFile, completeFilename), + ("enable", keepGoing enableCmd, noCompletion), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' (info False), completeIdentifier), + ("info!", keepGoing' (info True), completeIdentifier), + ("issafe", keepGoing' isSafeCmd, completeModule), + ("ignore", keepGoing ignoreCmd, noCompletion), + ("kind", keepGoing' (kindOfType False), completeIdentifier), + ("kind!", keepGoing' (kindOfType True), completeIdentifier), + ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), + ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile), + ("list", keepGoing' listCmd, noCompletion), + ("module", keepGoing moduleCmd, completeSetModule), + ("main", keepGoing runMain, completeFilename), + ("print", keepGoing printCmd, completeExpression), + ("quit", quit, noCompletion), + ("reload", keepGoing' reloadModule, noCompletion), + ("reload!", keepGoing' reloadModuleDefer, noCompletion), + ("run", keepGoing' runRun, completeFilename), + ("script", keepGoing' scriptCmd, completeFilename), + ("set", keepGoing setCmd, completeSetOptions), + ("seti", keepGoing setiCmd, completeSeti), + ("show", keepGoing' showCmd, completeShowOptions), + ("showi", keepGoing showiCmd, completeShowiOptions), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepout", keepGoing stepOutCmd, noCompletion), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoing' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("unadd", keepGoingPaths unAddModule, completeFilename), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, completeSetOptions), + ("where", keepGoing whereCmd, noCompletion), + ("instances", keepGoing' instancesCmd, completeExpression) + ] ++ map mkCmdHidden [ -- hidden commands + ("all-types", keepGoing' allTypesCmd), + ("complete", keepGoing completeCmd), + ("loc-at", keepGoing' locAtCmd), + ("type-at", keepGoing' typeAtCmd), + ("uses", keepGoing' usesCmd) + ] + where + mkCmd (n,a,c) = Command { cmdName = n + , cmdAction = a + , cmdHidden = False + , cmdCompletionFunc = c + } + + mkCmdHidden (n,a) = Command { cmdName = n + , cmdAction = a + , cmdHidden = True + , cmdCompletionFunc = noCompletion + } + +-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters. +-- This can be overridden for a particular command (for example, filename +-- expansion shouldn't consider '/' to be a word break) by setting the third +-- entry in the Command tuple above. +-- +-- NOTE: in order for us to override the default correctly, any custom entry +-- must be a SUBSET of word_break_chars. +word_break_chars :: String +word_break_chars = spaces ++ specials ++ symbols + +word_break_chars_pred :: Char -> Bool +word_break_chars_pred '.' = False +word_break_chars_pred c = c `elem` (spaces ++ specials) || isSymbolChar c + +symbols, specials, spaces :: String +symbols = "!#$%&*+/<=>?@\\^|-~" +specials = "(),;[]`{}" +spaces = " \t\n" + +flagWordBreakChars :: String +flagWordBreakChars = " \t\n" + + +showSDocForUser' :: GHC.GhcMonad m => SDoc -> m String +showSDocForUser' doc = do + dflags <- getDynFlags + unit_state <- hsc_units <$> GHC.getSession + name_ppr_ctx <- GHC.getNamePprCtx + pure $ showSDocForUser dflags unit_state name_ppr_ctx doc + +showSDocForUserQualify :: GHC.GhcMonad m => SDoc -> m String +showSDocForUserQualify doc = do + dflags <- getDynFlags + unit_state <- hsc_units <$> GHC.getSession + pure $ showSDocForUser dflags unit_state alwaysQualify doc + + +keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) +keepGoing a str = keepGoing' (lift . a) str + +keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome +keepGoing' a str = do + a str + return CmdSuccess + +keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome) +keepGoingPaths a str + = do case toArgsNoLoc str of + Left err -> reportError (GhciInvalidArgumentString err) >> return CmdSuccess + Right args -> keepGoing' a args + +defFullHelpText :: String +defFullHelpText = + " Commands available from the prompt:\n" ++ + "\n" ++ + " evaluate/run \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ + " :add [*] ... add module(s) to the current target set\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ + " :cd change directory to \n" ++ + " :cmd run the commands returned by ::IO String\n" ++ + " :complete [] list completions for partial input string\n" ++ + " :def[!] define command : (later defined command has\n" ++ + " precedence, :: is always a builtin command)\n" ++ + " (!: redefine an existing command name)\n" ++ + " :doc display docs for the given name (experimental)\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ + " :help, :? display this list of commands\n" ++ + " :info[!] [ ...] display information about the given names\n" ++ + " (!: do not filter instances)\n" ++ + " :instances display the class instances available for \n" ++ + " :issafe [] display safe haskell information of module \n" ++ + " :kind[!] show the kind of \n" ++ + " (!: also print the normalised type)\n" ++ + " :load[!] [*] ... load module(s) and their dependents\n" ++ + " (!: defer type errors)\n" ++ + " :main [ ...] run the main function with the given arguments\n" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ + " :quit exit GHCi\n" ++ + " :reload[!] reload the current module set\n" ++ + " (!: defer type errors)\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ + " :script run the script \n" ++ + " :type show the type of \n" ++ + " :type +d show the type of , defaulting type variables\n" ++ + " :unadd ... remove module(s) from the current target set\n" ++ + " :undef undefine user-defined command :\n" ++ + " :: run the builtin command\n" ++ + " :! run the shell command \n" ++ + "\n" ++ + " -- Commands for debugging:\n" ++ + "\n" ++ + " :abandon at a breakpoint, abandon current computation\n" ++ + " :back [] go back in the history N steps (after :trace)\n" ++ + " :break [] [] set a breakpoint at the specified location\n" ++ + " :break set a breakpoint on the specified function\n" ++ + " :continue [] resume after a breakpoint [and set break ignore count]\n" ++ + " :delete ... delete the specified breakpoints\n" ++ + " :delete * delete all breakpoints\n" ++ + " :disable ... disable the specified breakpoints\n" ++ + " :disable * disable all breakpoints\n" ++ + " :enable ... enable the specified breakpoints\n" ++ + " :enable * enable all breakpoints\n" ++ + " :force print , forcing unevaluated parts\n" ++ + " :forward [] go forward in the history N step s(after :back)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :ignore for break set break ignore \n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ + " :print [ ...] show a value without forcing its computation\n" ++ + " :sprint [ ...] simplified version of :print\n" ++ + " :step single-step after stopping at a breakpoint\n"++ + " :step single-step into \n"++ + " :steplocal single-step within the current top-level binding\n"++ + " :stepout stop at the first breakpoint after returning from the current scope\n"++ + " :stepmodule single-step restricted to the current module\n"++ + " :trace trace after stopping at a breakpoint\n"++ + " :trace evaluate with tracing on (see :history)\n"++ + + "\n" ++ + " -- Commands for changing settings:\n" ++ + "\n" ++ + " :set