From ee1f7966b3cdfd8f868605db4072c30bc75073b8 Mon Sep 17 00:00:00 2001 From: Shayne Fletcher Date: Mon, 27 Jan 2025 20:46:17 -0500 Subject: [PATCH] ghc-prim is merged with ghc-internal: fix ghc-lib-test-mini-compile --- CI.hs | 10 +- .../ghc-lib-test-mini-compile.cabal | 1 + .../ghc-lib-test-mini-compile/src/Main.hs | 9 +- .../test/GHC/Internal/Prim.hs | 1 + .../ghc-lib-test-mini-compile/test/Main.hs | 18 ++-- .../test/MiniCompileTestGhcInternalPrim.hs | 92 +++++++++++++++++++ examples/ghc-lib-test-utils/src/TestUtils.hs | 16 ++++ 7 files changed, 131 insertions(+), 16 deletions(-) create mode 100644 examples/ghc-lib-test-mini-compile/test/GHC/Internal/Prim.hs create mode 100644 examples/ghc-lib-test-mini-compile/test/MiniCompileTestGhcInternalPrim.hs diff --git a/CI.hs b/CI.hs index 2f2ce1bc..87de0805 100755 --- a/CI.hs +++ b/CI.hs @@ -100,7 +100,7 @@ data DaFlavor = DaFlavor -- Last tested gitlab.haskell.org/ghc/ghc.git at current :: String -current = "70f7741acd9d50a6cc07553aeaae600afe4a72b8" -- 2025-01-26 +current = "70f7741acd9d50a6cc07553aeaae600afe4a72b8" -- 2025-01-27 ghcFlavorOpt :: GhcFlavor -> String ghcFlavorOpt = \case @@ -421,13 +421,7 @@ buildDists ghcFlavor noGhcCheckout noBuilds versionSuffix = do cmd "cabal build --ghc-options=-j all" system_ $ "cd examples/ghc-lib-test-mini-hlint && cabal test --project-dir ../.. --test-show-details direct --test-options \"--color always --test-command ../../ghc-lib-test-mini-hlint " ++ ghcFlavorArg ++ "\"" - - -- TODO: Fix me. This test is failing since ghc-prim merged with - -- ghc-internal - -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/13752 - case ghcFlavor of - GhcMaster _ -> pure () - _ -> system_ $ "cd examples/ghc-lib-test-mini-compile && cabal test --project-dir ../.. --test-show-details direct --test-options \"--color always --test-command ../../ghc-lib-test-mini-compile " ++ ghcFlavorArg ++ "\"" + system_ $ "cd examples/ghc-lib-test-mini-compile && cabal test --project-dir ../.. --test-show-details direct --test-options \"--color always --test-command ../../ghc-lib-test-mini-compile " ++ ghcFlavorArg ++ "\"" system_ "cabal -v0 exec -- ghc -ignore-dot-ghci -package=ghc-lib-parser -e \"print 1\"" system_ "cabal -v0 exec -- ghc -ignore-dot-ghci -package=ghc-lib -e \"print 1\"" diff --git a/examples/ghc-lib-test-mini-compile/ghc-lib-test-mini-compile.cabal b/examples/ghc-lib-test-mini-compile/ghc-lib-test-mini-compile.cabal index 775b4a9c..3455e580 100644 --- a/examples/ghc-lib-test-mini-compile/ghc-lib-test-mini-compile.cabal +++ b/examples/ghc-lib-test-mini-compile/ghc-lib-test-mini-compile.cabal @@ -22,6 +22,7 @@ executable ghc-lib-test-mini-compile , containers , directory , extra + , filepath , ghc-lib-parser , ghc-lib hs-source-dirs: src diff --git a/examples/ghc-lib-test-mini-compile/src/Main.hs b/examples/ghc-lib-test-mini-compile/src/Main.hs index e846d030..decca5d4 100644 --- a/examples/ghc-lib-test-mini-compile/src/Main.hs +++ b/examples/ghc-lib-test-mini-compile/src/Main.hs @@ -54,6 +54,7 @@ import Paths_ghc_lib import System.Environment import System.Directory +import System.FilePath(takeDirectory) import System.IO.Extra import qualified Data.Map.Strict as Map import Data.IORef @@ -63,12 +64,14 @@ main = do args <- getArgs case args of [file] -> do + let dir = takeDirectory file s <- readFile' file flags <- mkDynFlags file s dataDir <- getDataDir createDirectoryIfMissing True $ dataDir ++ "/../mingw" -- hack: avoid "could not detect toolchain mingw" cm <- runGhc (Just dataDir) $ do - setSessionDynFlags flags + let searchPaths = [dir] + setSessionDynFlags flags { importPaths = searchPaths } compileToCoreSimplified file putStrLn $ showSDoc flags $ ppr cm _ -> fail "Exactly one file argument required" @@ -77,8 +80,10 @@ ghclibPrimUnitId :: String ghclibPrimUnitId = #if defined (DAML_UNIT_IDS) "daml-prim" -#else +#elif defined(GHC_9_12) || defined (GHC_9_10) || defined (GHC_9_8) || defined (GHC_9_6) || defined (GHC_9_4) || defined (GHC_9_2) || defined (GHC_9_0) || defined (GHC_8_10) || defined (GHC_8_8) "ghc-prim" +#else + "ghc-internal" #endif -- Create a DynFlags which is sufficiently filled in to work, but not diff --git a/examples/ghc-lib-test-mini-compile/test/GHC/Internal/Prim.hs b/examples/ghc-lib-test-mini-compile/test/GHC/Internal/Prim.hs new file mode 100644 index 00000000..34e9be9c --- /dev/null +++ b/examples/ghc-lib-test-mini-compile/test/GHC/Internal/Prim.hs @@ -0,0 +1 @@ +module GHC.Internal.Prim where diff --git a/examples/ghc-lib-test-mini-compile/test/Main.hs b/examples/ghc-lib-test-mini-compile/test/Main.hs index 79116680..f5da04b5 100644 --- a/examples/ghc-lib-test-mini-compile/test/Main.hs +++ b/examples/ghc-lib-test-mini-compile/test/Main.hs @@ -2,7 +2,7 @@ -- its affiliates. All rights reserved. SPDX-License-Identifier: -- (Apache-2.0 OR BSD-3-Clause) -{-# OPTIONS_GHC -Werror=unused-imports -Werror=unused-local-binds -Werror=unused-top-binds -Werror=orphans #-} +-- {-# OPTIONS_GHC -Werror=unused-imports -Werror=unused-local-binds -Werror=unused-top-binds -Werror=orphans #-} import Test.Tasty import Test.Tasty.Options @@ -14,9 +14,12 @@ import Data.List.Extra import TestUtils import System.Process.Extra import System.IO.Extra +import System.Directory main :: IO () main = do + currentDir <- getCurrentDirectory + putStrLn $ "Current directory: " ++ currentDir defaultMainWithIngredients ings $ askOption $ \ cmd@(CommandFile _) -> askOption $ \ config@(StackYaml _) -> @@ -34,11 +37,14 @@ main = do : defaultIngredients tests :: CommandFile -> StackYaml -> Resolver -> GhcFlavor -> TestTree -tests miniCompile _stackYaml _stackResolver _ghcFlavor = testGroup " All tests" - [ testCase "MiniCompileTest.hs" $ testMiniCompileTestHs miniCompile ] +tests miniCompile _stackYaml _stackResolver ghcFlavor = + testGroup "All tests" [ testCase "MiniCompileTestHs" $ testMiniCompileTestHs miniCompile ghcFlavor] -testMiniCompileTestHs :: CommandFile -> IO () -testMiniCompileTestHs (CommandFile miniCompile) = do +testMiniCompileTestHs :: CommandFile -> GhcFlavor -> IO () +testMiniCompileTestHs (CommandFile miniCompile) ghcFlavor = do cmd <- readFile' miniCompile - out <- systemOutput_ $ cmd ++ "test/MiniCompileTest.hs" + out <- systemOutput_ $ + cmd ++ case ghcSeries ghcFlavor of + s | s < GHC_9_14 -> "test/MiniCompileTest.hs" + s | otherwise -> "test/MiniCompileTestGhcInternalPrim.hs" assertBool "MiniCompileTest.hs" (isJust $ stripInfix "$tc'TyCon :: TyCon" out) diff --git a/examples/ghc-lib-test-mini-compile/test/MiniCompileTestGhcInternalPrim.hs b/examples/ghc-lib-test-mini-compile/test/MiniCompileTestGhcInternalPrim.hs new file mode 100644 index 00000000..d484e0c7 --- /dev/null +++ b/examples/ghc-lib-test-mini-compile/test/MiniCompileTestGhcInternalPrim.hs @@ -0,0 +1,92 @@ +-- Copyright (c) 2019-2025, Digital Asset (Switzerland) GmbH and/or +-- its affiliates. All rights reserved. SPDX-License-Identifier: +-- (Apache-2.0 OR BSD-3-Clause) +-- Based on +-- https://github.com/ghc/ghc/blob/23f6f31dd66d7c370cb8beec3f1d96a0cb577393/libraries/ghc-prim/GHC/Types.hs + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MagicHash #-} + +module GHC.Internal.Types ( + -- Data types that are built-in syntax + -- They are defined here, but not explicitly exported + -- + -- Lists: []( [], (::) ) + + Bool(..), Int (..), Word, TextLit, + Ordering(..), + Symbol, + ifThenElse, + Multiplicity(..) + ) where + +import GHC.Internal.Prim + +infixr 5 : + +-- | The kind of constraints, like `Show a` +data Constraint + +data Multiplicity = Many | One + +-- | (Kind) This is the kind of type-level symbols. +-- Declared here because class IP needs it +data Symbol + +-- | Documentation for lists +data [] a = [] | a : [a] + + +-- | Information about ordering +data Ordering = LT | EQ | GT + +-- | A 64-bit integer. +data Int = + I# Int# + +-- This is a dummy type we need for string literals. +data Char + +type TextLit = [Char] + +-- A dummy type for Word. +data Word + +data Bool = False | True + +isTrue# :: Int# -> Bool +{-# INLINE isTrue# #-} +isTrue# x = tagToEnum# x + +ifThenElse :: Bool -> a -> a -> a +ifThenElse c t f = case c of True -> t; False -> f + +data Module = Module + TrName -- Package name + TrName -- Module name + +data TrName + = TrNameS Addr# -- Static + | TrNameD [Char] -- Dynamic + +type KindBndr = Int + +data RuntimeRep + +data KindRep = KindRepTyConApp TyCon [KindRep] + | KindRepVar !KindBndr + | KindRepApp KindRep KindRep + | KindRepFun KindRep KindRep + | KindRepTYPE !RuntimeRep + | KindRepTypeLitS TypeLitSort Addr# + | KindRepTypeLitD TypeLitSort [Char] + +data TypeLitSort = TypeLitSymbol + | TypeLitNat + | TypeLitChar + +data TyCon = TyCon Word# Word# -- Fingerprint + Module -- Module in which this is defined + TrName -- Type constructor name + Int# -- How many kind variables do we accept? + KindRep -- A representation of the type's kind diff --git a/examples/ghc-lib-test-utils/src/TestUtils.hs b/examples/ghc-lib-test-utils/src/TestUtils.hs index 6ada6e31..1ca8d5bf 100644 --- a/examples/ghc-lib-test-utils/src/TestUtils.hs +++ b/examples/ghc-lib-test-utils/src/TestUtils.hs @@ -64,6 +64,9 @@ data GhcVersion | GhcMaster deriving (Eq, Ord, Typeable) +data GhcSeries = GHC_8_8 | GHC_8_10 | GHC_9_0 | GHC_9_2 | GHC_9_4 | GHC_9_6 | GHC_9_8 | GHC_9_10 | GHC_9_12 | GHC_9_14 + deriving (Eq, Ord) + instance Show GhcVersion where show = showGhcVersion @@ -106,6 +109,19 @@ showGhcVersion = \case newtype GhcFlavor = GhcFlavor GhcVersion deriving (Eq, Ord, Typeable) +ghcSeries :: GhcFlavor -> GhcSeries +ghcSeries (GhcFlavor f) + | DaGhc881 <= f && f < Ghc8101 = GHC_8_8 + | Ghc8101 <= f && f < Ghc901 = GHC_8_10 + | Ghc901 <= f && f < Ghc921 = GHC_9_0 + | Ghc921 <= f && f < Ghc941 = GHC_9_2 + | Ghc941 <= f && f < Ghc961 = GHC_9_4 + | Ghc961 <= f && f < Ghc981 = GHC_9_6 + | Ghc981 <= f && f < Ghc9101 = GHC_9_8 + | Ghc9101 <= f && f < Ghc9121 = GHC_9_10 + | Ghc9121 <= f && f < GhcMaster = GHC_9_12 + | otherwise = GHC_9_14 + readFlavor :: String -> Maybe GhcFlavor readFlavor = (GhcFlavor <$>) . \case