Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Add support for GHC 9.4.1 #152

Merged
merged 2 commits into from
Jun 15, 2023
Merged

Add support for GHC 9.4.1 #152

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
bf20c6d
Add support for GHC 9.4
christiaanb May 22, 2023
05bfce9
Disable environment files in packagedb test
christiaanb May 23, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
3 changes: 2 additions & 1 deletion .github/workflows/ci.yml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,7 @@ jobs:
- stack-8.10.7.yaml
- stack-9.0.2.yaml
- stack-9.2.3.yaml
- stack-9.4.3.yaml
os:
- ubuntu-latest

Expand All @@ -41,7 +42,7 @@ jobs:
.stack-work
key: ${{ runner.os }}-stack-${{ hashFiles(matrix.stack_yaml) }}

- uses: haskell/actions/setup@v1
- uses: haskell/actions/setup@v2
id: setup-haskell-stack
name: Setup Stack
with:
Expand Down
2 changes: 1 addition & 1 deletion hint.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -64,7 +64,7 @@ library
default-language: Haskell2010
build-depends: base == 4.*,
containers,
ghc >= 8.4 && < 9.3,
ghc >= 8.4 && < 9.5,
ghc-paths,
ghc-boot,
transformers,
Expand Down
50 changes: 29 additions & 21 deletions src/Hint/Context.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,7 @@
import System.FilePath
import System.Directory

import Data.Maybe (maybe)

Check warning on line 35 in src/Hint/Context.hs

View workflow job for this annotation

GitHub Actions / stack-9.4.3.yaml 

The import of ‘Data.Maybe’ is redundant

Check warning on line 35 in src/Hint/Context.hs

View workflow job for this annotation

GitHub Actions / newest (latest, ubuntu-latest) 

The import of ‘Data.Maybe’ is redundant

Check warning on line 35 in src/Hint/Context.hs

View workflow job for this annotation

GitHub Actions / stack-8.8.4.yaml 

The import of ‘Data.Maybe’ is redundant

Check warning on line 35 in src/Hint/Context.hs

View workflow job for this annotation

GitHub Actions / stack-9.2.3.yaml 

The import of ‘Data.Maybe’ is redundant

Check warning on line 35 in src/Hint/Context.hs

View workflow job for this annotation

GitHub Actions / stack-8.10.7.yaml 

The import of ‘Data.Maybe’ is redundant

Check warning on line 35 in src/Hint/Context.hs

View workflow job for this annotation

GitHub Actions / stack-9.0.2.yaml 

The import of ‘Data.Maybe’ is redundant
import Hint.Configuration (setGhcOption)
import System.IO.Temp

Expand Down Expand Up @@ -108,16 +108,13 @@
setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m ()
setContextModules as = setContext as . map (GHC.simpleImportDecl . GHC.moduleName)

fileTarget :: FilePath -> GHC.Target
fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing
where next_phase = GHC.Cpp GHC.HsSrcFile

addPhantomModule :: MonadInterpreter m
=> (ModuleName -> ModuleText)
-> m PhantomModule
addPhantomModule mod_text =
do pm <- newPhantomModule
let t = fileTarget (pmFile pm)
df <- runGhc GHC.getSessionDynFlags
let t = GHC.fileTarget df (pmFile pm)
m = GHC.mkModuleName (pmName pm)
--
liftIO $ writeFile (pmFile pm) (mod_text $ pmName pm)
Expand All @@ -128,7 +125,7 @@
(old_top, old_imps) <- runGhc getContext
gelisam marked this conversation as resolved.
Show resolved Hide resolved
--
runGhc $ GHC.addTarget t
res <- runGhc $ GHC.load (GHC.LoadUpTo m)
res <- runGhc $ GHC.loadPhantomModule m
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't understand. With ghc-9.4, loadPhantomModule m is defined as GHC.load GHC.LoadAllTargets, which does not mention m. So where does m get loaded?

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Also, this comment says that calling getContext and then setContext does not work anymore, because the saved context refers to the modules using some internal IDs which are no longer valid after calling LoadAllTargets. So why is the code still using getContext and setContext? Is the comment wrong, and setContext does work after all?

Copy link
Contributor

@gelisam gelisam Jun 14, 2023 •
edited

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I now think that setContext does fail, but then the caller fixes it.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

where does m get loaded?

I now understand that addTarget t followed by LoadAllTargets does load t 🙃

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I tried removing the allegedly-broken getContext and setContext calls, but that broke the test_work_in_main test. I was thus wrong: the caller does not fix setContext, and in fact, setContext does work fine.

--
if isSucceeded res
then do runGhc $ setContext old_top old_imps
Expand Down Expand Up @@ -167,7 +164,8 @@
else return True
--
let file_name = pmFile pm
runGhc $ GHC.removeTarget (GHC.targetId $ fileTarget file_name)
runGhc $ do df <- GHC.getSessionDynFlags
GHC.removeTarget (GHC.targetId $ GHC.fileTarget df file_name)
--
onState (\s -> s{activePhantoms = filter (pm /=) $ activePhantoms s})
--
Expand Down Expand Up @@ -220,10 +218,7 @@
doLoad fs = mayFail $ do
targets <- mapM (\f->runGhc $ GHC.guessTarget f Nothing) fs
--
runGhc $ GHC.setTargets targets
res <- runGhc $ GHC.load GHC.LoadAllTargets
-- loading the targets removes the support module
reinstallSupportModule
res <- reinstallSupportModule (Just targets)
return $ guard (isSucceeded res) >> Just ()

-- | Returns True if the module was interpreted.
Expand Down Expand Up @@ -385,14 +380,27 @@
cleanPhantomModules
--
-- Now, install a support module
installSupportModule
res <- installSupportModule Nothing
mayFail (return $ guard (isSucceeded res) >> Just ())

-- Load a phantom module with all the symbols from the prelude we need
installSupportModule :: MonadInterpreter m => m ()
installSupportModule = do mod <- addPhantomModule support_module
onState (\st -> st{hintSupportModule = mod})
mod' <- findModule (pmName mod)
runGhc $ setContext [mod'] []
installSupportModule :: MonadInterpreter m => Maybe [GHC.Target] -> m GHC.SuccessFlag
installSupportModule tM = do mod <- addPhantomModule support_module
onState (\st -> st{hintSupportModule = mod})
case tM of
Nothing -> do
mod' <- findModule (pmName mod)
runGhc $ setContext [mod'] []
return GHC.Succeeded
gelisam marked this conversation as resolved.
Show resolved Hide resolved
Just ts -> do
runGhc $ GHC.setTargets ts
df <- runGhc GHC.getSessionDynFlags
let t = GHC.fileTarget df (pmFile mod)
runGhc $ GHC.addTarget t
res <- runGhc $ GHC.load GHC.LoadAllTargets
gelisam marked this conversation as resolved.
Show resolved Hide resolved
mod' <- findModule (pmName mod)
runGhc $ setContext [mod'] []
return res
--
where support_module m = unlines [
"module " ++ m ++ "( ",
Expand All @@ -413,10 +421,10 @@

-- Call it when the support module is an active phantom module but has been
-- unloaded as a side effect by GHC (e.g. by calling GHC.loadTargets)
reinstallSupportModule :: MonadInterpreter m => m ()
reinstallSupportModule = do pm <- fromState hintSupportModule
removePhantomModule pm
installSupportModule
reinstallSupportModule :: Maybe [GHC.Target] -> MonadInterpreter m => m GHC.SuccessFlag
reinstallSupportModule tM = do pm <- fromState hintSupportModule
removePhantomModule pm
installSupportModule tM

altStringName :: ModuleName -> String
altStringName mod_name = "String_" ++ mod_name
Expand Down