[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: compiler: Turn `FinderCache` into a record of operations so that GHC API clients can
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Jul 2 17:58:56 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9da3948a by Zubin Duggal at 2024-07-02T13:58:24-04:00
compiler: Turn `FinderCache` into a record of operations so that GHC API clients can
have full control over how its state is managed by overriding `hsc_FC`.
Also removes the `uncacheModule` function as this wasn't being used by anything
since 1893ba12fe1fa2ade35a62c336594afcd569736e
Fixes #23604
- - - - -
aa3236e3 by Oleg Grenrus at 2024-07-02T13:58:26-04:00
Add reflections of GHC.TypeLits/Nats type families
-------------------------
Metric Increase:
ghc_experimental_dir
ghc_experimental_so
-------------------------
- - - - -
febb2766 by Adam Gundry at 2024-07-02T13:58:28-04:00
Correct -Wpartial-fields warning to say "Definition" rather than "Use"
Fixes #24710. The message and documentation for `-Wpartial-fields` were
misleading as (a) the warning occurs at definition sites rather than use
sites, and (b) the warning relates to the definition of a field independently
of the selector function (e.g. because record updates are also partial).
- - - - -
7c5be613 by Max Ulidtko at 2024-07-02T13:58:29-04:00
GHCi: Support local Prelude
Fixes #10920, an issue where GHCi bails out when started alongside a
file named Prelude.hs or Prelude.lhs (even empty file suffices).
The in-source Note [GHCi and local Preludes] documents core reasoning.
Supplementary changes:
* add debug traces for module lookups under -ddump-if-trace;
* drop stale comment in GHC.Iface.Load;
* reduce noise in -v3 traces from GHC.Utils.TmpFs;
* new test, which also exercizes HomeModError.
- - - - -
906bf796 by Mike Pilgrem at 2024-07-02T13:58:36-04:00
Fix #25032 Refer to Cabal's `includes` field, not `include-files`
- - - - -
19b24877 by Matthew Pickering at 2024-07-02T13:58:36-04:00
ci: Use nixpkgs-20.04-darwin channel for darwin toolchain
We are currently seeing a couple of errors on darwin machines after I
bumped the toolchain commit.
```
last 10 log lines:
> from .extern.jaraco.text import yield_lines
> File "/private/tmp/nix-build-python3.11-setuptools-69.5.1.drv-0/source/setuptools/_vendor/jaraco/text/__init__.py", line 12, in <module>
> from setuptools.extern.jaraco.context import ExceptionTrap
> File "/private/tmp/nix-build-python3.11-setuptools-69.5.1.drv-0/source/setuptools/_vendor/jaraco/context.py", line 11, in <module>
> import urllib.request
> File "/nix/store/z3ccgikilqsd1kzjf1sr03wbnjyga4hh-python3-minimal-3.11.9/lib/python3.11/urllib/request.py", line 2656, in <module>
> from _scproxy import _get_proxy_settings, _get_proxies
> ModuleNotFoundError: No module named '_scproxy'
>
> ERROR Backend 'setuptools.build_meta' is not available.
```
In theory this channel should be tested so it should work?
- - - - -
29 changed files:
- .gitlab/darwin/nix/sources.json
- compiler/GHC.hs
- compiler/GHC/Iface/Env.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Utils/TmpFs.hs
- docs/users_guide/9.12.1-notes.rst
- docs/users_guide/exts/ffi.rst
- docs/users_guide/using-warnings.rst
- ghc/GHCi/UI.hs
- libraries/ghc-experimental/ghc-experimental.cabal
- + libraries/ghc-experimental/src/GHC/TypeLits/Experimental.hs
- + libraries/ghc-experimental/src/GHC/TypeNats/Experimental.hs
- testsuite/tests/diagnostic-codes/codes.stdout
- + testsuite/tests/ghci/should_run/LocalPrelude/Prelude.hs
- + testsuite/tests/ghci/should_run/T10920.hs
- + testsuite/tests/ghci/should_run/T10920.script
- + testsuite/tests/ghci/should_run/T10920.stderr
- + testsuite/tests/ghci/should_run/T10920.stdout
- testsuite/tests/ghci/should_run/all.T
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- + testsuite/tests/numeric/should_run/T24245.hs
- + testsuite/tests/numeric/should_run/T24245.stdout
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/overloadedrecflds/should_fail/DRFPartialFields.stderr
- testsuite/tests/typecheck/should_compile/T7169.stderr
Changes:
=====================================
.gitlab/darwin/nix/sources.json
=====================================
@@ -12,15 +12,15 @@
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"nixpkgs": {
- "branch": "nixos-unstable",
+ "branch": "nixpkgs-24.05-darwin",
"description": "Nix Packages collection",
"homepage": "",
"owner": "nixos",
"repo": "nixpkgs",
- "rev": "2893f56de08021cffd9b6b6dfc70fd9ccd51eb60",
- "sha256": "1anwxmjpm21msnnlrjdz19w31bxnbpn4kgf93sn3npihi7wf4a8h",
+ "rev": "66f253e5b2d6b03a67dfbf68a3b3be99db5f517f",
+ "sha256": "08zz89dhqbf3h87kixwrs2f1813lbkn7ckm3ijndhn1rzq412a70",
"type": "tarball",
- "url": "https://github.com/nixos/nixpkgs/archive/2893f56de08021cffd9b6b6dfc70fd9ccd51eb60.tar.gz",
+ "url": "https://github.com/nixos/nixpkgs/archive/66f253e5b2d6b03a67dfbf68a3b3be99db5f517f.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
}
}
=====================================
compiler/GHC.hs
=====================================
@@ -365,6 +365,7 @@ import GHC.Parser.Lexer
import GHC.Parser.Annotation
import GHC.Parser.Utils
+import GHC.Iface.Env ( trace_if )
import GHC.Iface.Load ( loadSysInterface )
import GHC.Hs
import GHC.Builtin.Types.Prim ( alphaTyVars )
@@ -1713,6 +1714,7 @@ findModule mod_name maybe_pkg = do
findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
+ liftIO $ trace_if (hsc_logger hsc_env) (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual)
let mhome_unit = hsc_home_unit_maybe hsc_env
let dflags = hsc_dflags hsc_env
case pkgqual of
@@ -1775,7 +1777,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name
lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)
-lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env ->
+lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> do
+ liftIO $ trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModule" <+> ppr mod_name <+> ppr uid)
case lookupHug (hsc_HUG hsc_env) uid mod_name of
Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
_not_a_home_module -> return Nothing
=====================================
compiler/GHC/Iface/Env.hs
=====================================
@@ -269,9 +269,9 @@ newIfaceNames occs
| (occ,uniq) <- occs `zip` uniqs] }
trace_if :: Logger -> SDoc -> IO ()
-{-# INLINE trace_if #-}
+{-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities]
trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc
trace_hi_diffs :: Logger -> SDoc -> IO ()
-{-# INLINE trace_hi_diffs #-}
+{-# INLINE trace_hi_diffs #-} -- see Note [INLINE conditional tracing utilities]
trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -444,9 +444,6 @@ loadInterface doc_str mod from
; case lookupIfaceByModule hug (eps_PIT eps) mod of {
Just iface
-> return (Succeeded iface) ; -- Already loaded
- -- The (src_imp == mi_boot iface) test checks that the already-loaded
- -- interface isn't a boot iface. This can conceivably happen,
- -- if an earlier import had a before we got to real imports. I think.
_ -> do {
-- READ THE MODULE IN
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1501,8 +1501,9 @@ instance Diagnostic TcRnMessage where
text "You may define an abstract closed type family" $$
text "only in a .hs-boot file"
TcRnPartialFieldSelector fld -> mkSimpleDecorated $
- sep [text "Use of partial record field selector" <> colon,
- nest 2 $ quotes (ppr (occName fld))]
+ vcat [ sep [ text "Definition of partial record field" <> colon
+ , nest 2 $ quotes (ppr (occName fld)) ]
+ , text "Record selection and update using this field will be partial." ]
TcRnHasFieldResolvedIncomplete name -> mkSimpleDecorated $
text "The invocation of `getField` on the record field" <+> quotes (ppr name)
<+> text "may produce an error since it is not defined for all data constructors"
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -3503,7 +3503,7 @@ data TcRnMessage where
-}
TcRnAbstractClosedTyFamDecl :: TcRnMessage
- {-| TcRnPartialFieldSelector is a warning indicating that a record selector
+ {-| TcRnPartialFieldSelector is a warning indicating that a record field
was not defined for all constructors of a data type.
Test cases:
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -5,15 +5,15 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Module finder
module GHC.Unit.Finder (
FindResult(..),
InstalledFindResult(..),
FinderOpts(..),
- FinderCache,
+ FinderCache(..),
initFinderCache,
- flushFinderCaches,
findImportedModule,
findPluginModule,
findExactModule,
@@ -26,14 +26,10 @@ module GHC.Unit.Finder (
mkObjPath,
addModuleToFinder,
addHomeModuleToFinder,
- uncacheModule,
mkStubPaths,
findObjectLinkableMaybe,
findObjectLinkable,
-
- -- Hash cache
- lookupFileCache
) where
import GHC.Prelude
@@ -91,41 +87,35 @@ type BaseName = OsPath -- Basename of file
initFinderCache :: IO FinderCache
-initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv
- <*> newIORef M.empty
-
--- remove all the home modules from the cache; package modules are
--- assumed to not move around during a session; also flush the file hash
--- cache
-flushFinderCaches :: FinderCache -> UnitEnv -> IO ()
-flushFinderCaches (FinderCache ref file_ref) ue = do
- atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
- atomicModifyIORef' file_ref $ \_ -> (M.empty, ())
- where
- is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
-
-addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
-addToFinderCache (FinderCache ref _) key val =
- atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())
-
-removeFromFinderCache :: FinderCache -> InstalledModule -> IO ()
-removeFromFinderCache (FinderCache ref _) key =
- atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())
-
-lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
-lookupFinderCache (FinderCache ref _) key = do
- c <- readIORef ref
- return $! lookupInstalledModuleEnv c key
-
-lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint
-lookupFileCache (FinderCache _ ref) key = do
- c <- readIORef ref
- case M.lookup key c of
- Nothing -> do
- hash <- getFileHash key
- atomicModifyIORef' ref $ \c -> (M.insert key hash c, ())
- return hash
- Just fp -> return fp
+initFinderCache = do
+ mod_cache <- newIORef emptyInstalledModuleEnv
+ file_cache <- newIORef M.empty
+ let flushFinderCaches :: UnitEnv -> IO ()
+ flushFinderCaches ue = do
+ atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
+ atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
+ where
+ is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
+
+ addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
+ addToFinderCache key val =
+ atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c key val, ())
+
+ lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
+ lookupFinderCache key = do
+ c <- readIORef mod_cache
+ return $! lookupInstalledModuleEnv c key
+
+ lookupFileCache :: FilePath -> IO Fingerprint
+ lookupFileCache key = do
+ c <- readIORef file_cache
+ case M.lookup key c of
+ Nothing -> do
+ hash <- getFileHash key
+ atomicModifyIORef' file_cache $ \c -> (M.insert key hash c, ())
+ return hash
+ Just fp -> return fp
+ return FinderCache{..}
-- -----------------------------------------------------------------------------
-- The three external entry points
@@ -343,11 +333,6 @@ addHomeModuleToFinder fc home_unit mod_name loc = do
addToFinderCache fc mod (InstalledFound loc mod)
return (mkHomeModule home_unit mod_name)
-uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO ()
-uncacheModule fc home_unit mod_name = do
- let mod = mkHomeInstalledModule home_unit mod_name
- removeFromFinderCache fc mod
-
-- -----------------------------------------------------------------------------
-- The internal workers
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -1,6 +1,7 @@
module GHC.Unit.Finder.Types
( FinderCache (..)
, FinderCacheState
+ , FileCacheState
, FindResult (..)
, InstalledFindResult (..)
, FinderOpts(..)
@@ -13,8 +14,8 @@ import GHC.Data.OsPath
import qualified Data.Map as M
import GHC.Fingerprint
import GHC.Platform.Ways
+import GHC.Unit.Env
-import Data.IORef
import GHC.Data.FastString
import qualified Data.Set as Set
@@ -25,8 +26,17 @@ import qualified Data.Set as Set
--
type FinderCacheState = InstalledModuleEnv InstalledFindResult
type FileCacheState = M.Map FilePath Fingerprint
-data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState)
- , fcFileCache :: (IORef FileCacheState)
+data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
+ -- ^ remove all the home modules from the cache; package modules are
+ -- assumed to not move around during a session; also flush the file hash
+ -- cache.
+ , addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
+ -- ^ Add a found location to the cache for the module.
+ , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
+ -- ^ Look for a location in the cache.
+ , lookupFileCache :: FilePath -> IO Fingerprint
+ -- ^ Look for the hash of a file in the cache. This should add it to the
+ -- cache. If the file doesn't exist, raise an IOException.
}
data InstalledFindResult
=====================================
compiler/GHC/Utils/TmpFs.hs
=====================================
@@ -377,18 +377,27 @@ the process id).
This is ok, as the temporary directory used contains the pid (see getTempDir).
-}
+
+manyWithTrace :: Logger -> String -> ([FilePath] -> IO ()) -> [FilePath] -> IO ()
+manyWithTrace _ _ _ [] = pure () -- do silent nothing on zero filepaths
+manyWithTrace logger phase act paths
+ = traceCmd logger phase ("Deleting: " ++ unwords paths) (act paths)
+
removeTmpDirs :: Logger -> [FilePath] -> IO ()
-removeTmpDirs logger ds
- = traceCmd logger "Deleting temp dirs"
- ("Deleting: " ++ unwords ds)
- (mapM_ (removeWith logger removeDirectory) ds)
+removeTmpDirs logger
+ = manyWithTrace logger "Deleting temp dirs"
+ (mapM_ (removeWith logger removeDirectory))
+
+removeTmpSubdirs :: Logger -> [FilePath] -> IO ()
+removeTmpSubdirs logger
+ = manyWithTrace logger "Deleting temp subdirs"
+ (mapM_ (removeWith logger removeDirectory))
removeTmpFiles :: Logger -> [FilePath] -> IO ()
removeTmpFiles logger fs
= warnNon $
- traceCmd logger "Deleting temp files"
- ("Deleting: " ++ unwords deletees)
- (mapM_ (removeWith logger removeFile) deletees)
+ manyWithTrace logger "Deleting temp files"
+ (mapM_ (removeWith logger removeFile)) deletees
where
-- Flat out refuse to delete files that are likely to be source input
-- files (is there a worse bug than having a compiler delete your source
@@ -405,12 +414,6 @@ removeTmpFiles logger fs
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
-removeTmpSubdirs :: Logger -> [FilePath] -> IO ()
-removeTmpSubdirs logger fs
- = traceCmd logger "Deleting temp subdirs"
- ("Deleting: " ++ unwords fs)
- (mapM_ (removeWith logger removeDirectory) fs)
-
removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith logger remover f = remover f `Exception.catchIO`
(\e ->
=====================================
docs/users_guide/9.12.1-notes.rst
=====================================
@@ -85,6 +85,9 @@ Compiler
GHCi
~~~~
+- Fix a bug where GHCi would not start alongside a local file called ``Prelude.hs``
+ or ``Prelude.lhs`` (:ghc-ticket:`10920`).
+
Runtime system
~~~~~~~~~~~~~~
=====================================
docs/users_guide/exts/ffi.rst
=====================================
@@ -764,7 +764,7 @@ calls across module and package boundaries: there's no need for the header file
to be available when compiling an inlined version of a foreign call, so the
compiler is free to inline foreign calls in any context.
-The ``-#include`` option is now deprecated, and the ``include-files``
+The ``-#include`` option is now deprecated, and the ``includes``
field in a Cabal package specification is ignored.
Memory Allocation
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -2154,7 +2154,7 @@ of ``-W(no-)*``.
The option :ghc-flag:`-Wpartial-fields` warns about a record field
``f`` that is defined in some, but not all, of the constructors of a
- data type, as such selector functions are partial. For example, when
+ data type, as record selection and update will be partial. For example, when
:ghc-flag:`-Wpartial-fields` is enabled the compiler will emit a warning at
the definition of ``Foo`` below: ::
@@ -2164,8 +2164,9 @@ of ``-W(no-)*``.
data Foo = Foo { _f :: Int } | Bar
- Another related warning is :ghc-flag:`-Wincomplete-record-selectors`,
- which warns at use sites rather than definition sites.
+ Related warnings are :ghc-flag:`-Wincomplete-record-selectors` and
+ :ghc-flag:`-Wincomplete-record-updates`,
+ which warn at use sites rather than definition sites.
.. ghc-flag:: -Wunused-packages
:shortdesc: warn when package is requested on command line, but not needed.
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -2255,7 +2255,7 @@ keepPackageImports = filterM is_pkg_import
is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool
is_pkg_import (IIModule _) = return False
is_pkg_import (IIDecl d)
- = do pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
+ = do pkgqual <- GHC.renameRawPkgQualM mod_name (ideclPkgQual d)
e <- MC.try $ GHC.findQualifiedModule pkgqual mod_name
case e :: Either SomeException Module of
Left _ -> return False
@@ -2263,7 +2263,30 @@ keepPackageImports = filterM is_pkg_import
where
mod_name = unLoc (ideclName d)
+{- Note [GHCi and local Preludes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC's compilation manager has no issues when the package being compiled
+defines its own local Prelude module. It'll just shadow the Prelude from base.
+GHCi however must check this condition, when it calls setContext ["Prelude"]
+to prepopulate the interactive session's scope. This is because of two facts.
+
+1. setContext must use previously compiled .hi interfaces only; it cannot
+recurse into compiling .hs modules (even with LinkIntoMemory), simply because
+it's not the right phase to do it. Import resolution happens way before GHC
+properly "loads" modules (GHC.Linker.Loader.loadModule, GHC.load & siblings);
+or in other words, at time of setContext the linker isn't even initialized yet.
+
+2. The local Prelude.hs (or .lhs) may've never been compiled before, so its
+interface file Prelude.hi can be outdated or altogether missing.
+
+Thankfully, there's a simple solution: just let CM load the local Prelude normally
+(either as a :load target, or as a dependency of another target) later. To do that,
+detect if the implicit `import Prelude` resolves to the "home unit" (i.e. not base),
+and if so, omit it from the early setContext call.
+
+If we don't, a HomeModError will be (correctly) thrown. See #10920.
+-}
modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> LoadType -> m ()
modulesLoadedMsg ok mods load_type = do
@@ -2827,7 +2850,7 @@ checkAdd ii = do
m <- GHC.lookupQualifiedModule pkgqual modname
when safe $ do
t <- GHC.isModuleTrusted m
- when (not t) $ throwGhcException $ ProgramError $ ""
+ unless t $ throwGhcException $ ProgramError $ ""
-- -----------------------------------------------------------------------------
-- Update the GHC API's view of the context
@@ -2881,7 +2904,8 @@ getImplicitPreludeImports iidecls = do
, not (any (sameImpModule imp) iidecls) ]
else []
- return prel_iidecls
+ -- See Note [GHCi and local Preludes]
+ keepPackageImports prel_iidecls
-- -----------------------------------------------------------------------------
-- Utils on InteractiveImport
=====================================
libraries/ghc-experimental/ghc-experimental.cabal
=====================================
@@ -23,9 +23,11 @@ common warnings
library
import: warnings
exposed-modules:
- GHC.Profiling.Eras
- Data.Tuple.Experimental
Data.Sum.Experimental
+ Data.Tuple.Experimental
+ GHC.Profiling.Eras
+ GHC.TypeLits.Experimental
+ GHC.TypeNats.Experimental
Prelude.Experimental
if arch(wasm32)
exposed-modules: GHC.Wasm.Prim
=====================================
libraries/ghc-experimental/src/GHC/TypeLits/Experimental.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoStarIsType #-}
+{-# LANGUAGE TypeOperators #-}
+module GHC.TypeLits.Experimental (
+ appendSSymbol,
+ consSSymbol,
+ sCharToSNat,
+ sNatToSChar,
+) where
+
+import GHC.Internal.TypeLits
+import Data.Char (ord, chr)
+
+appendSSymbol :: SSymbol a -> SSymbol b -> SSymbol (AppendSymbol a b)
+appendSSymbol (UnsafeSSymbol a) (UnsafeSSymbol b) = UnsafeSSymbol (a ++ b)
+
+consSSymbol :: SChar a -> SSymbol b -> SSymbol (ConsSymbol a b)
+consSSymbol (UnsafeSChar a) (UnsafeSSymbol b) = UnsafeSSymbol (a : b)
+
+sCharToSNat :: SChar a -> SNat (CharToNat a)
+sCharToSNat (UnsafeSChar a) = UnsafeSNat (fromIntegral (ord a))
+
+sNatToSChar :: (n <= 1114111) => SNat n -> SChar (NatToChar n)
+sNatToSChar (UnsafeSNat n) = UnsafeSChar (chr (fromIntegral n))
=====================================
libraries/ghc-experimental/src/GHC/TypeNats/Experimental.hs
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoStarIsType #-}
+{-# LANGUAGE TypeOperators #-}
+module GHC.TypeNats.Experimental (
+ plusSNat,
+ timesSNat,
+ powerSNat,
+ minusSNat,
+ divSNat,
+ modSNat,
+ log2SNat,
+) where
+
+import GHC.Internal.TypeNats
+import GHC.Num.Natural (naturalLog2)
+
+plusSNat :: SNat n -> SNat m -> SNat (n + m)
+plusSNat (UnsafeSNat n) (UnsafeSNat m) = UnsafeSNat (n + m)
+
+timesSNat :: SNat n -> SNat m -> SNat (n * m)
+timesSNat (UnsafeSNat n) (UnsafeSNat m) = UnsafeSNat (n * m)
+
+powerSNat :: SNat n -> SNat m -> SNat (n ^ m)
+powerSNat (UnsafeSNat n) (UnsafeSNat m) = UnsafeSNat (n ^ m)
+
+minusSNat :: (m <= n) => SNat n -> SNat m -> SNat (n - m)
+minusSNat (UnsafeSNat n) (UnsafeSNat m) = UnsafeSNat (n - m)
+
+divSNat :: (1 <= m) => SNat n -> SNat m -> SNat (Div n m)
+divSNat (UnsafeSNat n) (UnsafeSNat m) = UnsafeSNat (div n m)
+
+modSNat :: (1 <= m) => SNat n -> SNat m -> SNat (Mod n m)
+modSNat (UnsafeSNat n) (UnsafeSNat m) = UnsafeSNat (mod n m)
+
+log2SNat :: (1 <= n) => SNat n -> SNat (Log2 n)
+log2SNat (UnsafeSNat n) = UnsafeSNat (fromIntegral (naturalLog2 n))
=====================================
testsuite/tests/diagnostic-codes/codes.stdout
=====================================
@@ -92,7 +92,6 @@
[GHC-41843] is untested (constructor = IOResultExpected)
[GHC-07641] is untested (constructor = AtLeastOneArgExpected)
[GHC-64852] is untested (constructor = BadSourceImport)
-[GHC-58427] is untested (constructor = HomeModError)
[GHC-94559] is untested (constructor = CouldntFindInFiles)
[GHC-22211] is untested (constructor = MissingPackageFiles)
[GHC-88719] is untested (constructor = MissingPackageWayFiles)
=====================================
testsuite/tests/ghci/should_run/LocalPrelude/Prelude.hs
=====================================
@@ -0,0 +1,9 @@
+module Prelude
+ (storefront, module Reexport) where
+
+import Data.Semigroup as Reexport ((<>))
+import System.IO as Reexport (putStrLn)
+
+storefront = "A project-local Prelude"
+
+backyard = "unexported local definition -- shall be visible only after *-import"
=====================================
testsuite/tests/ghci/should_run/T10920.hs
=====================================
@@ -0,0 +1,5 @@
+module Main where
+
+-- implicitly imports a custom Prelude module under LocalPrelude/
+
+main = putStrLn ("it's fine: " <> storefront)
=====================================
testsuite/tests/ghci/should_run/T10920.script
=====================================
@@ -0,0 +1,47 @@
+--
+-- Tests that we can don't crash with a local Prelude module present (bug #10920).
+--
+
+-- this is default, but the test makes zero sense with NoImplicitPrelude, it should *not* be set here
+:seti -XImplicitPrelude
+-- this is default too, (ab)used in the following macro
+:seti -fimplicit-import-qualified
+-- for a bit neater output
+:def! section \title -> let echo=System.IO.putStrLn in (echo "" GHC.Base.>> echo title GHC.Base.>> GHC.Base.return "")
+
+:section -- should not crash with local prelude
+:load T10920.hs
+:main
+:show imports
+:show modules
+
+:load
+:section -- unless loaded, HomeModError is expected (on stderr)
+import Prelude
+:show imports
+
+:load
+:section -- but if loaded, can be imported
+:load T10920
+import Prelude
+:t Prelude.storefront
+:show imports
+:show modules
+
+:load
+:section -- can also be star-imported
+:load T10920
+:module *Prelude
+:t Prelude.backyard
+:show imports
+:show modules
+
+-- also test ghci-script similar to what stack repl generates...
+-- the sequence is a tad weird, but it is what it is.
+:load
+:section -- double-loading is fine as well
+:add Prelude ./T10920.hs
+:module + Prelude
+:show imports
+:show modules
+:main
=====================================
testsuite/tests/ghci/should_run/T10920.stderr
=====================================
@@ -0,0 +1,3 @@
+<interactive>:1:1: error: [GHC-58427]
+ attempting to use module ‘main:Prelude’ (./Prelude.hs) which is not loaded
+
=====================================
testsuite/tests/ghci/should_run/T10920.stdout
=====================================
@@ -0,0 +1,28 @@
+
+-- should not crash with local prelude
+it's fine: A project-local Prelude
+:module +*Main -- added automatically
+Main ( T10920.hs, interpreted )
+Prelude ( Prelude.hs, interpreted )
+
+-- unless loaded, HomeModError is expected (on stderr)
+
+-- but if loaded, can be imported
+Prelude.storefront :: GHC.Internal.Base.String
+import Prelude
+:module +*Main -- added automatically
+Main ( T10920.hs, interpreted )
+Prelude ( Prelude.hs, interpreted )
+
+-- can also be star-imported
+Prelude.backyard :: GHC.Internal.Base.String
+:module +*Prelude
+Main ( T10920.hs, interpreted )
+Prelude ( Prelude.hs, interpreted )
+
+-- double-loading is fine as well
+import Prelude
+:module +*Main -- added automatically
+Main ( T10920.hs, interpreted )
+Prelude ( Prelude.hs, interpreted )
+it's fine: A project-local Prelude
=====================================
testsuite/tests/ghci/should_run/all.T
=====================================
@@ -94,3 +94,5 @@ test('GhciMainIs', just_ghci, compile_and_run, ['-main-is otherMain'])
test('LargeBCO', [extra_files(['LargeBCO_A.hs']), req_interp, extra_hc_opts("-O -fbyte-code-and-object-code -fprefer-byte-code")], compile_and_run, [''])
test('T24115', just_ghci + [extra_run_opts("-e ':add T24115.hs'")], ghci_script, ['T24115.script'])
+
+test('T10920', [only_ways(ghci_ways), extra_files(['LocalPrelude/Prelude.hs'])], ghci_script, ['T10920.script'])
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -4322,6 +4322,23 @@ module GHC.Profiling.Eras where
incrementUserEra :: GHC.Types.Word -> GHC.Types.IO GHC.Types.Word
setUserEra :: GHC.Types.Word -> GHC.Types.IO ()
+module GHC.TypeLits.Experimental where
+ -- Safety: Safe-Inferred
+ appendSSymbol :: forall (a :: GHC.Types.Symbol) (b :: GHC.Types.Symbol). GHC.Internal.TypeLits.SSymbol a -> GHC.Internal.TypeLits.SSymbol b -> GHC.Internal.TypeLits.SSymbol (GHC.Internal.TypeLits.AppendSymbol a b)
+ consSSymbol :: forall (a :: GHC.Types.Char) (b :: GHC.Types.Symbol). GHC.Internal.TypeLits.SChar a -> GHC.Internal.TypeLits.SSymbol b -> GHC.Internal.TypeLits.SSymbol (GHC.Internal.TypeLits.ConsSymbol a b)
+ sCharToSNat :: forall (a :: GHC.Types.Char). GHC.Internal.TypeLits.SChar a -> GHC.Internal.TypeNats.SNat (GHC.Internal.TypeLits.CharToNat a)
+ sNatToSChar :: forall (n :: GHC.Num.Natural.Natural). (n GHC.Internal.Data.Type.Ord.<= 1114111) => GHC.Internal.TypeNats.SNat n -> GHC.Internal.TypeLits.SChar (GHC.Internal.TypeLits.NatToChar n)
+
+module GHC.TypeNats.Experimental where
+ -- Safety: None
+ divSNat :: forall (m :: GHC.Num.Natural.Natural) (n :: GHC.Internal.TypeNats.Nat). (1 GHC.Internal.Data.Type.Ord.<= m) => GHC.Internal.TypeNats.SNat n -> GHC.Internal.TypeNats.SNat m -> GHC.Internal.TypeNats.SNat (GHC.Internal.TypeNats.Div n m)
+ log2SNat :: forall (n :: GHC.Num.Natural.Natural). (1 GHC.Internal.Data.Type.Ord.<= n) => GHC.Internal.TypeNats.SNat n -> GHC.Internal.TypeNats.SNat (GHC.Internal.TypeNats.Log2 n)
+ minusSNat :: forall (m :: GHC.Internal.TypeNats.Nat) (n :: GHC.Internal.TypeNats.Nat). (m GHC.Internal.Data.Type.Ord.<= n) => GHC.Internal.TypeNats.SNat n -> GHC.Internal.TypeNats.SNat m -> GHC.Internal.TypeNats.SNat (n GHC.Internal.TypeNats.- m)
+ modSNat :: forall (m :: GHC.Num.Natural.Natural) (n :: GHC.Internal.TypeNats.Nat). (1 GHC.Internal.Data.Type.Ord.<= m) => GHC.Internal.TypeNats.SNat n -> GHC.Internal.TypeNats.SNat m -> GHC.Internal.TypeNats.SNat (GHC.Internal.TypeNats.Mod n m)
+ plusSNat :: forall (n :: GHC.Internal.TypeNats.Nat) (m :: GHC.Internal.TypeNats.Nat). GHC.Internal.TypeNats.SNat n -> GHC.Internal.TypeNats.SNat m -> GHC.Internal.TypeNats.SNat (n GHC.Internal.TypeNats.+ m)
+ powerSNat :: forall (n :: GHC.Internal.TypeNats.Nat) (m :: GHC.Internal.TypeNats.Nat). GHC.Internal.TypeNats.SNat n -> GHC.Internal.TypeNats.SNat m -> GHC.Internal.TypeNats.SNat (n GHC.Internal.TypeNats.^ m)
+ timesSNat :: forall (n :: GHC.Internal.TypeNats.Nat) (m :: GHC.Internal.TypeNats.Nat). GHC.Internal.TypeNats.SNat n -> GHC.Internal.TypeNats.SNat m -> GHC.Internal.TypeNats.SNat (n GHC.Internal.TypeNats.* m)
+
module Prelude.Experimental where
-- Safety: Trustworthy
type CSolo :: Constraint -> Constraint
=====================================
testsuite/tests/numeric/should_run/T24245.hs
=====================================
@@ -0,0 +1,83 @@
+{-# LANGUAGE DataKinds #-}
+module Main where
+
+import GHC.TypeLits
+import GHC.TypeNats.Experimental
+import GHC.TypeLits.Experimental
+
+main :: IO ()
+main = do
+ testBinary plusSNat (SNat @2) (SNat @3) SNat
+ testBinary timesSNat (SNat @2) (SNat @3) SNat
+ testBinary powerSNat (SNat @2) (SNat @3) SNat
+ testBinary minusSNat (SNat @7) (SNat @3) SNat
+ testBinary divSNat (SNat @7) (SNat @3) SNat
+ testBinary modSNat (SNat @7) (SNat @3) SNat
+ testUnary log2SNat (SNat @7) SNat
+
+ testBinaryS appendSSymbol (SSymbol @"foo") (SSymbol @"bar") SSymbol
+ testBinaryCSS consSSymbol (SChar @'x') (SSymbol @"yz") SSymbol
+ testUnaryCN sCharToSNat (SChar @'x') SNat
+ testUnaryNC sNatToSChar (SNat @62) SChar
+
+testBinary
+ :: (SNat a -> SNat b -> SNat c)
+ -> SNat a
+ -> SNat b
+ -> SNat c
+ -> IO ()
+testBinary f n m p = do
+ print (f n m, p)
+ assertEqualOnShow (f n m) p
+
+testUnary
+ :: (SNat a -> SNat b)
+ -> SNat a
+ -> SNat b
+ -> IO ()
+testUnary f n m = do
+ print (f n, m)
+ assertEqualOnShow (f n) m
+
+testBinaryS
+ :: (SSymbol a -> SSymbol b -> SSymbol c)
+ -> SSymbol a
+ -> SSymbol b
+ -> SSymbol c
+ -> IO ()
+testBinaryS f n m p = do
+ print (f n m, p)
+ assertEqualOnShow (f n m) p
+
+testBinaryCSS
+ :: (SChar a -> SSymbol b -> SSymbol c)
+ -> SChar a
+ -> SSymbol b
+ -> SSymbol c
+ -> IO ()
+testBinaryCSS f n m p = do
+ print (f n m, p)
+ assertEqualOnShow (f n m) p
+
+testUnaryCN
+ :: (SChar a -> SNat b)
+ -> SChar a
+ -> SNat b
+ -> IO ()
+testUnaryCN f n m = do
+ print (f n, m)
+ assertEqualOnShow (f n) m
+
+testUnaryNC
+ :: (SNat a -> SChar b)
+ -> SNat a
+ -> SChar b
+ -> IO ()
+testUnaryNC f n m = do
+ print (f n, m)
+ assertEqualOnShow (f n) m
+
+assertEqualOnShow :: Show a => a -> a -> IO ()
+assertEqualOnShow x y
+ | show x == show y = return ()
+ | otherwise = fail "inequality"
=====================================
testsuite/tests/numeric/should_run/T24245.stdout
=====================================
@@ -0,0 +1,11 @@
+(SNat @5,SNat @5)
+(SNat @6,SNat @6)
+(SNat @8,SNat @8)
+(SNat @4,SNat @4)
+(SNat @2,SNat @2)
+(SNat @1,SNat @1)
+(SNat @2,SNat @2)
+(SSymbol @"foobar",SSymbol @"foobar")
+(SSymbol @"xyz",SSymbol @"xyz")
+(SNat @120,SNat @120)
+(SChar @'>',SChar @'>')
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -85,3 +85,4 @@ test('T22671', js_fragile(24259), compile_and_run, [''])
test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers'])
test('T24066', normal, compile_and_run, [''])
test('div01', normal, compile_and_run, [''])
+test('T24245', normal, compile_and_run, [''])
=====================================
testsuite/tests/overloadedrecflds/should_fail/DRFPartialFields.stderr
=====================================
@@ -1,3 +1,4 @@
DRFPartialFields.hs:4:17: error: [GHC-82712] [-Wpartial-fields, Werror=partial-fields]
- Use of partial record field selector: ‘foo’
+ Definition of partial record field: ‘foo’
+ Record selection and update using this field will be partial.
=====================================
testsuite/tests/typecheck/should_compile/T7169.stderr
=====================================
@@ -1,2 +1,3 @@
T7169.hs:11:5: warning: [GHC-82712] [-Wpartial-fields]
- Use of partial record field selector: ‘m2’
+ Definition of partial record field: ‘m2’
+ Record selection and update using this field will be partial.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da2bc6be12efa219720984f65c60161aafaca94f...19b24877b0407dcb5f10ac01bd69264bd0ce867a
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da2bc6be12efa219720984f65c60161aafaca94f...19b24877b0407dcb5f10ac01bd69264bd0ce867a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240702/614bc5ce/attachment-0001.html>
More information about the ghc-commits
mailing list