Port to GHC 9.2.

YoshikiTakashima · Dec 26, 2022 · 7506926 · 7506926
1 parent b86fb5b
commit 7506926
Show file tree

Hide file tree

Showing 57 changed files with 430 additions and 383 deletions.
diff --git a/benchmark-timings/benchmark-timings.cabal b/benchmark-timings/benchmark-timings.cabal
@@ -36,8 +36,8 @@ executable benchmark-timings
     build-depends:    base
                     , aeson >= 1.5.6 && < 2.1
                     , cassava ^>=0.5.2
-                    , bytestring ^>=0.10.12
-                    , optparse-applicative ^>=0.16.1
+                    , bytestring >=0.10.12 && <0.12
+                    , optparse-applicative >=0.16.1 && <0.18
     ghc-options:    -Wall
     hs-source-dirs:   app
     default-language: Haskell2010

diff --git a/cabal.project b/cabal.project
@@ -1,4 +1,4 @@
-with-compiler: ghc-9.0.2
+with-compiler: ghc-9.2.5
 
 packages: .
           ./liquid-base
@@ -19,6 +19,8 @@ source-repository-package
     location: https://github.com/qnikst/ghc-timings-report
     tag: 45ef3498e35897712bde8e002ce18df6d55f8b15
 
+allow-newer: ghc-timings:base, rest-rewrite:time
+
 package liquid-fixpoint
   flags: +devel
 

diff --git a/liquid-base/liquid-base.cabal b/liquid-base/liquid-base.cabal
@@ -247,11 +247,7 @@ library
   build-depends:      
                       liquid-ghc-prim
                     , liquidhaskell        >= 0.8.10.1
-  if impl(ghc < 9)
-    build-depends:    integer-gmp < 1.0.4.0
-                    , base                 == 4.14.3.0
-  else
-    build-depends:    base                 ^>= 4.15.0.0
+  build-depends:      base                 ^>= 4.16.0.0
   default-language:   Haskell2010
   default-extensions: PackageImports
                       NoImplicitPrelude

diff --git a/liquid-bytestring/liquid-bytestring.cabal b/liquid-bytestring/liquid-bytestring.cabal
@@ -48,7 +48,7 @@ library
 
   hs-source-dirs:     src
   build-depends:      liquid-base          < 5
-                    , bytestring           >= 0.10.10.0 && < 0.11
+                    , bytestring           >= 0.10.10.0 && < 0.12
                     , liquidhaskell        >= 0.8.10.1
   default-language:   Haskell2010
   default-extensions: PackageImports

diff --git a/liquid-ghc-prim/liquid-ghc-prim.cabal b/liquid-ghc-prim/liquid-ghc-prim.cabal
@@ -36,7 +36,7 @@ library
                     GHC.Types
 
   hs-source-dirs:     src
-  build-depends:      ghc-prim             >= 0.6.1 && < 0.8
+  build-depends:      ghc-prim             >= 0.6.1 && < 0.9
                     , liquidhaskell        >= 0.8.10.1
   default-language:   Haskell2010
   default-extensions: PackageImports

diff --git a/liquid-prelude/liquid-prelude.cabal b/liquid-prelude/liquid-prelude.cabal
@@ -29,7 +29,7 @@ library
                     KMeansHelper
   hs-source-dirs:     src
   build-depends:      liquid-base          < 5
-                    , bytestring           >= 0.10.0.0 && < 0.11
+                    , bytestring           >= 0.10.0.0 && < 0.12
                     , containers           >= 0.6.0.0  && < 0.7
                     , liquidhaskell        >= 0.8.10.2
   default-language:   Haskell2010

diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal
@@ -195,7 +195,7 @@ library
                     , aeson
                     , binary
                     , bytestring           >= 0.10
-                    , Cabal                < 3.5
+                    , Cabal                < 3.7
                     , cereal
                     , cmdargs              >= 0.10
                     , containers           >= 0.5
@@ -205,7 +205,7 @@ library
                     , filepath             >= 1.3
                     , fingertree           >= 0.1
                     , exceptions           < 0.11
-                    , ghc                  ^>= 9
+                    , ghc                  ^>= 9.2
                     , ghc-boot
                     , ghc-paths            >= 0.1
                     , ghc-prim
@@ -215,7 +215,7 @@ library
                     , liquid-fixpoint      >= 0.8.10.2.1 && < 0.9
                     , mtl                  >= 2.1
                     , optics               >= 0.2
-                    , optparse-applicative < 0.17
+                    , optparse-applicative < 0.18
                     , githash
                     , megaparsec           >= 8
                     , pretty               >= 1.1

diff --git a/src-ghc/Liquid/GHC/API.hs b/src-ghc/Liquid/GHC/API.hs
@@ -23,7 +23,6 @@ module Liquid.GHC.API (
   , moduleUnitId
   , thisPackage
   , renderWithStyle
-  , mkUserStyle
   , pattern LitNumber
   , dataConSig
   , getDependenciesModuleNames
@@ -45,7 +44,7 @@ import GHC.Builtin.Types              as Ghc
 import GHC.Builtin.Types.Prim         as Ghc
 import GHC.Builtin.Utils              as Ghc
 import GHC.Core                       as Ghc hiding (AnnExpr, AnnExpr' (..), AnnRec, AnnCase)
-import GHC.Core.Class                 as Ghc
+import GHC.Core.Class                 as Ghc hiding (FunDep)
 import GHC.Core.Coercion              as Ghc
 import GHC.Core.Coercion.Axiom        as Ghc
 import GHC.Core.ConLike               as Ghc
@@ -67,12 +66,10 @@ import GHC.Data.Bag                   as Ghc
 import GHC.Data.FastString            as Ghc
 import GHC.Data.Graph.Directed        as Ghc
 import GHC.Data.Pair                  as Ghc
-import GHC.Driver.Finder              as Ghc
 import GHC.Driver.Main                as Ghc
 import GHC.Driver.Phases              as Ghc (Phase(StopLn))
 import GHC.Driver.Pipeline            as Ghc (compileFile)
-import GHC.Driver.Session             as Ghc hiding (isHomeModule)
-import GHC.Driver.Types               as Ghc
+import GHC.Driver.Session             as Ghc
 import GHC.Driver.Monad               as Ghc (withSession)
 import GHC.HsToCore.Monad             as Ghc
 import GHC.Iface.Syntax               as Ghc
@@ -86,22 +83,44 @@ import GHC.Plugins                    as Ghc ( deserializeWithData
                                              , extendIdSubst
                                              , substExpr
                                              )
+import GHC.Core.FVs                   as Ghc (exprFreeVarsList)
+import GHC.Core.Opt.OccurAnal         as Ghc
+import GHC.Driver.Env                 as Ghc
+import GHC.Driver.Ppr                 as Ghc
+import GHC.HsToCore.Expr              as Ghc
+import GHC.Iface.Load                 as Ghc
+import GHC.Rename.Expr                as Ghc (rnLExpr)
+import GHC.Runtime.Context            as Ghc
+import GHC.Tc.Gen.App                 as Ghc (tcInferSigma)
+import GHC.Tc.Gen.Bind                as Ghc (tcValBinds)
+import GHC.Tc.Gen.Expr                as Ghc (tcInferRho)
 import GHC.Tc.Instance.Family         as Ghc
 import GHC.Tc.Module                  as Ghc
+import GHC.Tc.Solver                  as Ghc
 import GHC.Tc.Types                   as Ghc
+import GHC.Tc.Types.Evidence          as Ghc
+import GHC.Tc.Types.Origin            as Ghc (lexprCtOrigin)
 import GHC.Tc.Utils.Monad             as Ghc hiding (getGHCiMonad)
 import GHC.Tc.Utils.TcType            as Ghc (tcSplitDFunTy, tcSplitMethodTy)
+import GHC.Tc.Utils.Zonk              as Ghc
 import GHC.Types.Annotations          as Ghc
 import GHC.Types.Avail                as Ghc
 import GHC.Types.Basic                as Ghc
 import GHC.Types.CostCentre           as Ghc
+import GHC.Types.Error                as Ghc
+import GHC.Types.Fixity               as Ghc
 import GHC.Types.Id                   as Ghc hiding (lazySetIdInfo, setIdExported, setIdNotExported)
 import GHC.Types.Id.Info              as Ghc
 import GHC.Types.Literal              as Ghc hiding (LitNumber)
+import qualified GHC.Types.Literal    as Ghc
 import GHC.Types.Name                 as Ghc hiding (varName, isWiredIn)
 import GHC.Types.Name.Reader          as Ghc
 import GHC.Types.Name.Set             as Ghc
+import GHC.Types.SourceError          as Ghc
+import GHC.Types.SourceText           as Ghc
 import GHC.Types.SrcLoc               as Ghc
+import GHC.Types.Tickish              as Ghc
+import GHC.Types.TypeEnv              as Ghc
 import GHC.Types.Unique               as Ghc
 import GHC.Types.Unique.DFM           as Ghc
 import GHC.Types.Unique.FM            as Ghc
@@ -110,22 +129,21 @@ import GHC.Types.Unique.Supply        as Ghc
 import GHC.Types.Var                  as Ghc
 import GHC.Types.Var.Env              as Ghc
 import GHC.Types.Var.Set              as Ghc
+import GHC.Unit.External              as Ghc
+import GHC.Unit.Finder                as Ghc
+import GHC.Unit.Home.ModInfo          as Ghc
 import GHC.Unit.Module                as Ghc
+import GHC.Unit.Module.Deps           as Ghc
+import GHC.Unit.Module.Graph          as Ghc
+import GHC.Unit.Module.ModDetails     as Ghc
+import GHC.Unit.Module.ModGuts        as Ghc
+import GHC.Unit.Module.ModSummary     as Ghc
 import GHC.Utils.Error                as Ghc
-import GHC.Utils.Outputable           as Ghc hiding ((<>), integer, renderWithStyle, mkUserStyle)
+import GHC.Utils.Logger               as Ghc
+import GHC.Utils.Misc                 as Ghc (zipEqual)
+import GHC.Utils.Outputable           as Ghc (mkUserStyle)
+import GHC.Utils.Outputable           as Ghc hiding ((<>), integer, mkUserStyle)
 import GHC.Utils.Panic                as Ghc
-import qualified GHC.Types.Literal    as Ghc
-import qualified GHC.Utils.Outputable as Ghc
-import GHC.Tc.Types.Origin            as Ghc (lexprCtOrigin)
-import GHC.Rename.Expr                as Ghc (rnLExpr)
-import GHC.Tc.Gen.Expr                as Ghc (tcInferSigma, tcInferRho)
-import GHC.Tc.Gen.Bind                as Ghc (tcValBinds)
-import GHC.Tc.Solver                  as Ghc
-import GHC.Tc.Utils.Zonk              as Ghc
-import GHC.Core.FVs                   as Ghc (exprFreeVarsList)
-import GHC.Tc.Types.Evidence          as Ghc
-import GHC.HsToCore.Expr              as Ghc
-import GHC.Core.Opt.OccurAnal         as Ghc
 
 -- 'fsToUnitId' is gone in GHC 9, but we can bring code it in terms of 'fsToUnit' and 'toUnitId'.
 fsToUnitId :: FastString -> UnitId
@@ -135,15 +153,15 @@ moduleUnitId :: Module -> UnitId
 moduleUnitId = toUnitId . moduleUnit
 
 thisPackage :: DynFlags -> UnitId
-thisPackage = toUnitId . homeUnit
+thisPackage = homeUnitId_
 
 -- See NOTE [tyConRealArity].
 tyConRealArity :: TyCon -> Int
 tyConRealArity tc = go 0 (tyConKind tc)
   where
     go :: Int -> Kind -> Int
     go !acc k =
-      case asum [fmap (view _3) (splitFunTy_maybe k), fmap snd (splitForAllTy_maybe k)] of
+      case asum [fmap (view _3) (splitFunTy_maybe k), fmap snd (splitForAllTyCoVar_maybe k)] of
         Nothing -> acc
         Just ks -> go (acc + 1) ks
 
@@ -154,10 +172,7 @@ getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]
 getDependenciesModuleNames = dep_mods
 
 renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
-renderWithStyle dynflags sdoc style = Ghc.renderWithStyle (Ghc.initSDocContext dynflags style) sdoc
-
-mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle
-mkUserStyle _ = Ghc.mkUserStyle
+renderWithStyle dynflags sdoc style = Ghc.renderWithContext (Ghc.initSDocContext dynflags style) sdoc
 
 --
 -- Literal

diff --git a/src-ghc/Liquid/GHC/API/StableModule.hs b/src-ghc/Liquid/GHC/API/StableModule.hs
@@ -38,15 +38,12 @@ moduleUnitId = GHC.toUnitId . GHC.moduleUnit
 
 renderModule :: GHC.Module -> String
 renderModule m =    "Module { unitId = " <> (GHC.unitIdString . moduleUnitId $ m)
-                 <> ", name = " <> show (GHC.moduleName m)
+                 <> ", name = " <> GHC.moduleNameString (GHC.moduleName m)
                  <> " }"
 
 -- These two orphans originally lived inside module 'Language.Haskell.Liquid.Types.Types'.
 instance Hashable GHC.ModuleName where
-  hashWithSalt i = hashWithSalt i . show
-
-instance Show GHC.ModuleName where
-  show = GHC.moduleNameString
+  hashWithSalt i = hashWithSalt i . GHC.moduleNameString
 
 instance Hashable StableModule where
   hashWithSalt s (StableModule mdl) = hashWithSalt s (GHC.moduleStableString mdl)

diff --git a/src-ghc/Liquid/GHC/GhcMonadLike.hs b/src-ghc/Liquid/GHC/GhcMonadLike.hs
@@ -28,14 +28,13 @@ module Liquid.GHC.GhcMonadLike (
   , findModule
   , lookupModule
   , isBootInterface
+  , ApiComment(..)
   , apiComments
   ) where
 
 import Control.Monad.IO.Class
 import Control.Exception (throwIO)
 
-import Data.IORef (readIORef)
-
 import qualified Liquid.GHC.API   as Ghc
 import           Liquid.GHC.API   hiding ( ModuleInfo
                                                           , findModule
@@ -59,7 +58,6 @@ import GHC.Utils.Exception (ExceptionMonad)
 import qualified GHC.Core.Opt.Monad as CoreMonad
 import qualified GHC.Data.EnumSet as EnumSet
 
-import qualified Data.Map.Strict as M
 import Optics
 
 class HasHscEnv m where
@@ -107,10 +105,10 @@ getModSummary mdl = do
                       , not (isBootInterface . isBootSummary $ ms) ]
    case mods_by_name of
      [] -> do dflags <- getDynFlags
-              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
+              liftIO $ throwIO $ GhcApiError (showSDoc dflags (text "Module not part of module graph"))
      [ms] -> return ms
      multiple -> do dflags <- getDynFlags
-                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
+                    liftIO $ throwIO $ GhcApiError (showSDoc dflags (text "getModSummary is ambiguous: " <+> ppr multiple))
 
 
 -- Converts a 'IsBootInterface' into a 'Bool'.
@@ -132,7 +130,7 @@ lookupModSummary mdl = do
 lookupGlobalName :: GhcMonadLike m => Name -> m (Maybe TyThing)
 lookupGlobalName name = do
   hsc_env <- askHscEnv
-  liftIO $ lookupTypeHscEnv hsc_env name
+  liftIO $ lookupType hsc_env name
 
 -- NOTE(adn) Taken from the GHC API, adapted to work for a 'GhcMonadLike' monad.
 lookupName :: GhcMonadLike m => Name -> m (Maybe TyThing)
@@ -153,9 +151,8 @@ modInfoLookupName minf name = do
   hsc_env <- askHscEnv
   case lookupTypeEnv (minf_type_env minf) name of
     Just tyThing -> return (Just tyThing)
-    Nothing      -> do
-      eps   <- liftIO $ readIORef (hsc_EPS hsc_env)
-      return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name
+    Nothing      -> liftIO $ do
+      lookupType hsc_env name
 
 moduleInfoTc :: GhcMonadLike m => ModSummary -> TcGblEnv -> m ModuleInfo
 moduleInfoTc ms tcGblEnv = do
@@ -172,8 +169,7 @@ parseModule ms = do
   hsc_env <- askHscEnv
   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
   hpm <- liftIO $ hscParse hsc_env_tmp ms
-  return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
-                           (hpm_annotations hpm))
+  return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
 
 -- | Our own simplified version of 'TypecheckedModule'.
 data TypecheckedModule = TypecheckedModule { 
@@ -194,8 +190,7 @@ typecheckModule pmod = do
   (tc_gbl_env, rn_info)
         <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
                        HsParsedModule { hpm_module = parsedSource pmod,
-                                        hpm_src_files = pm_extra_src_files pmod,
-                                        hpm_annotations = pm_annotations pmod }
+                                        hpm_src_files = pm_extra_src_files pmod }
   return TypecheckedModule {
       tm_parsed_module  = pmod
     , tm_renamed_source = rn_info
@@ -249,13 +244,13 @@ findModule mod_name maybe_pkg = do
   let
     dflags   = hsc_dflags hsc_env
     this_pkg = thisPackage dflags
-  --
+    throwNoModError err = throwOneError $ noModError hsc_env noSrcSpan mod_name err
   case maybe_pkg of
     Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
       res <- findImportedModule hsc_env mod_name maybe_pkg
       case res of
         Found _ m -> return m
-        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err
+        err       -> throwNoModError err
     _otherwise -> do
       home <- lookupLoadedHomeModule mod_name
       case home of
@@ -265,7 +260,7 @@ findModule mod_name maybe_pkg = do
            case res of
              Found loc m | moduleUnitId m /= this_pkg -> return m
                          | otherwise -> modNotLoadedError dflags m loc
-             err -> throwOneError $ noModError dflags noSrcSpan mod_name err
+             err -> throwNoModError err
 
 
 lookupLoadedHomeModule :: GhcMonadLike m => ModuleName -> m (Maybe Module)
@@ -294,14 +289,27 @@ lookupModule mod_name Nothing = do
       res <- findExposedPackageModule hsc_env mod_name Nothing
       case res of
         Found _ m -> return m
-        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
-
--- Compatibility shim to extract the comments out of an 'ApiAnns', as modern GHCs now puts the
--- comments (i.e. Haskell comments) in a different field ('apiAnnRogueComments').
-apiComments :: ApiAnns -> [Ghc.Located AnnotationComment]
-apiComments apiAnns =
-  let comments = concat . M.elems . apiAnnComments $ apiAnns
-  in
-     map toRealSrc $ mappend comments (apiAnnRogueComments apiAnns)
+        err       ->
+          throwOneError $ noModError hsc_env noSrcSpan mod_name err
+
+-- | Abstraction of 'EpaComment'.
+data ApiComment
+  = ApiLineComment String
+  | ApiBlockComment String
+
+-- | Extract top-level comments from a module.
+apiComments :: ParsedModule -> [Ghc.Located ApiComment]
+apiComments pm =
+  case pm_parsed_source pm of
+    L _ (HsModule { hsmodAnn = anns' }) ->
+      mapMaybe (tokComment . toRealSrc) $
+      priorComments $
+      epAnnComments anns'
   where
-    toRealSrc (L x e) = L (RealSrcSpan x Nothing) e
+    tokComment (L sp (EpaComment (EpaLineComment s) _)) = Just (L sp (ApiLineComment s))
+    tokComment (L sp (EpaComment (EpaBlockComment s) _)) = Just (L sp (ApiBlockComment s))
+    tokComment _ = Nothing
+
+    -- TODO: take into account anchor_op, which only matters if the source was
+    -- pre-processed by an exact-print-aware tool.
+    toRealSrc (L a e) = L (RealSrcSpan (anchor a) Nothing) e