Add support for GHC 9.2.

Doesn't cover the plugin yet.

Author: sellout

.github/workflows/ci.yml

@@ -20,6 +20,7 @@ jobs:
           - "8.8.1"
           - "8.10.1"
           - "9.0.1"
+          - "9.2.1"
     steps:
       - uses: actions/checkout@v2
       - uses: haskell/actions/setup@v1

examples/src/ConCat/Dual.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TupleSections #-}

examples/src/ConCat/TArr.hs

@@ -45,7 +45,9 @@ import Prelude hiding (id, (.), const, curry, uncurry)  -- Coming from ConCat.Al
 import Data.Monoid
 import Data.Foldable
 import GHC.TypeLits
+#if !MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
 import GHC.Types (Nat)
+#endif
 import GHC.Generics (U1(..),Par1(..),(:*:)(..),(:.:)(..))
 import GHC.Exts (Coercible,coerce)
 

inline/src/ConCat/Inline/Plugin.hs

@@ -12,6 +12,10 @@ import qualified ConCat.Inline.ClassOp as CO
 import Data.List (elemIndex)
 
 -- GHC API
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+import qualified GHC.Driver.Backend as Backend
+import GHC.Types.TyThing (lookupId, lookupTyCon)
+#endif
 #if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
 import GHC.Core.Class (classAllSelIds)
 import GHC.Plugins
@@ -36,9 +40,14 @@ install _opts todos =
   do dflags <- getDynFlags
      -- Unfortunately, the plugin doesn't work in GHCi. Until fixed,
      -- disable under GHCi, so we can at least type-check conveniently.
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+     if backend dflags == Backend.Interpreter then
+        return todos
+#else
      if hscTarget dflags == HscInterpreted then
         return todos
-      else
+#endif
+     else
        do
 #if !MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)
           reinitializeGlobals

plugin/src/ConCat/Plugin.hs

@@ -59,7 +59,11 @@ import GHC.Runtime.Loader
 import GHC.Tc.Utils.TcType (isFloatTy,isDoubleTy,isIntegerTy,isIntTy,isBoolTy,isUnitTy
                            ,tcSplitTyConApp_maybe)
 import GHC.Types.Id.Make (mkDictSelRhs,coerceId)
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+import GHC.Builtin.Uniques (mkBuiltinUnique)
+#else
 import GHC.Types.Unique (mkBuiltinUnique)
+#endif
 import qualified GHC.Types.Unique.DFM as DFMap
 #else
 import GhcPlugins as GHC hiding (substTy,cat)

satisfy/src/ConCat/BuildDictionary.hs

@@ -38,7 +38,6 @@ import Control.Arrow (second)
 import GHC.Core.Predicate
 import GHC.Core.TyCo.Rep (CoercionHole(..), Type(..))
 import GHC.Core.TyCon (isTupleTyCon)
-import GHC.Driver.Finder (findExposedPackageModule)
 import GHC.HsToCore.Binds
 import GHC.HsToCore.Monad
 import GHC.Plugins
@@ -56,8 +55,16 @@ import GHC.Tc.Utils.Monad (getCtLocM,traceTc)
 import GHC.Tc.Utils.Zonk (emptyZonkEnv,zonkEvBinds)
 import GHC.Types.Unique (mkUniqueGrimily)
 import qualified GHC.Types.Unique.Set as NonDetSet
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+import GHC.Runtime.Context (InteractiveContext (..), InteractiveImport (..))
+import GHC.Types.Error (getErrorMessages, getWarningMessages)
+import GHC.Unit.Finder (FindResult (..), findExposedPackageModule)
+import GHC.Unit.Module.Deps (Dependencies (..))
+import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc)
+#else
+import GHC.Driver.Finder (findExposedPackageModule)
 import GHC.Utils.Error (pprErrMsgBagWithLoc)
-import GHC.Utils.Encoding (zEncodeString)
+#endif
 #else
 import GhcPlugins
 import TyCoRep (CoercionHole(..), Type(..))
@@ -82,7 +89,6 @@ import DsBinds
 import           TcSimplify
 import           TcRnTypes
 import ErrUtils (pprErrMsgBagWithLoc)
-import Encoding (zEncodeString)
 import Unique (mkUniqueGrimily)
 import Finder (findExposedPackageModule)
 
@@ -150,9 +156,15 @@ runTcM env0 dflags guts m = do
     orphans <- filterM (moduleIsOkay env0) (moduleName <$> dep_orphs (mg_deps guts))
     -- pprTrace' "runTcM orphans" (ppr orphans) (return ())
     (msgs, mr) <- runTcInteractive (env orphans) m
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+    let showMsgs msg = showSDoc dflags $ vcat $
+              text "Errors:"   : pprMsgEnvelopeBagWithLoc (getErrorMessages msg)
+           ++ text "Warnings:" : pprMsgEnvelopeBagWithLoc (getWarningMessages msg)
+#else
     let showMsgs (warns, errs) = showSDoc dflags $ vcat $
               text "Errors:"   : pprErrMsgBagWithLoc errs
            ++ text "Warnings:" : pprErrMsgBagWithLoc warns
+#endif
     maybe (fail $ showMsgs msgs) return mr
  where
    imports0 = ic_imports (hsc_IC env0)
@@ -265,7 +277,11 @@ reallyBuildDictionary env dflags guts uniqSupply _inScope evType evTypes ev goal
              then dict
              else case evIds of
                     [evId] -> mkCoreLet (NonRec evId ev) dict
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+                    _ -> mkWildCase' ev evType goalTy [Alt (DataAlt (tupleDataCon Boxed (length evIds))) evIds dict]
+#else
                     _ -> mkWildCase' ev evType goalTy [(DataAlt (tupleDataCon Boxed (length evIds)), evIds, dict)]
+#endif
 
 evVarName :: FastString
 evVarName = mkFastString "evidence"
@@ -346,8 +362,13 @@ annotateExpr fnId fnId' typeArgsCount expr0 =
     go _evVars expr@(Type _) = expr
     go _evVars expr@(Coercion _) = expr
 
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+    annotateAlt evVars (Alt con binders rhs) =
+      Alt con binders $ go (extendEvVarsList evVars binders) rhs
+#else
     annotateAlt evVars (con, binders, rhs) =
       (con, binders, go (extendEvVarsList evVars binders) rhs)
+#endif
 
 -- Maybe place in a GHC utils module.
 

satisfy/src/ConCat/Satisfy/Plugin.hs

@@ -10,6 +10,11 @@ module ConCat.Satisfy.Plugin where
 import System.IO.Unsafe (unsafePerformIO)
 
 -- GHC API
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+import GHC.Core.Unfold (defaultUnfoldingOpts)
+import qualified GHC.Driver.Backend as Backend
+import GHC.Utils.Logger (getLogger)
+#endif
 #if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
 import GHC.Core.Class (classAllSelIds)
 import GHC.Core.Make (mkCoreTup)
@@ -43,8 +48,14 @@ install _opts todos =
   do dflags <- getDynFlags
      -- Unfortunately, the plugin doesn't work in GHCi. Until fixed,
      -- disable under GHCi, so we can at least type-check conveniently.
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+     logger <- getLogger
+     if backend dflags == Backend.Interpreter then
+        return todos
+#else
      if hscTarget dflags == HscInterpreted then
         return todos
+#endif
       else do
 #if !MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)
           reinitializeGlobals
@@ -74,6 +85,12 @@ install _opts todos =
                             , sm_inline     = False -- important
                             , sm_eta_expand = False -- ??
                             , sm_case_case  = True
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+                            , sm_uf_opts = defaultUnfoldingOpts
+                            , sm_pre_inline = False
+                            , sm_logger = logger
+
+#endif
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0)
                             , sm_dflags     = dflags
 #endif

satisfy/src/ConCat/Simplify.hs

@@ -23,15 +23,22 @@ module ConCat.Simplify (simplifyE) where
 import System.IO.Unsafe (unsafePerformIO)
 
 #if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
+#if !MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
 import GHC.Core (emptyRuleEnv)
+#endif
 import GHC.Core.FamInstEnv (emptyFamInstEnvs)
 import GHC.Core.Opt.OccurAnal (occurAnalyseExpr)
 import GHC.Core.Opt.Simplify (simplExpr)
 import GHC.Core.Opt.Simplify.Env
 import GHC.Core.Opt.Simplify.Monad (SimplM,initSmpl)
 import GHC.Core.Stats (exprSize)
 import GHC.Plugins
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+import GHC.Core.Unfold (defaultUnfoldingOpts)
+import qualified GHC.Utils.Logger as Err
+#else
 import qualified GHC.Utils.Error as Err
+#endif
 #else
 import GhcPlugins
 import Simplify (simplExpr)
@@ -44,10 +51,15 @@ import OccurAnal (occurAnalyseExpr)
 import FamInstEnv (emptyFamInstEnvs)
 #endif
 
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+dumpIfSet_dyn' :: Err.Logger -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
+dumpIfSet_dyn' logger dflags dumpFlag str =
+  Err.dumpIfSet_dyn logger dflags dumpFlag str Err.FormatCore
+#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
 dumpIfSet_dyn' :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
-#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
 dumpIfSet_dyn' dflags dumpFlag str = Err.dumpIfSet_dyn dflags dumpFlag str Err.FormatCore
 #else
+dumpIfSet_dyn' :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn' = Err.dumpIfSet_dyn
 #endif
 
@@ -71,15 +83,26 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
 --
 -- Also used by Template Haskell
 simplifyExpr dflags inline expr
-  = do us <- mkSplitUniqSupply 'r'
-       let sz = exprSize expr
+  = do let sz = exprSize expr
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+       logger <- Err.initLogger
+       (expr', counts) <- initSmpl logger dflags emptyRuleEnv
+                            emptyFamInstEnvs sz
+                            (simplExprGently (simplEnvForCcc dflags inline logger) expr)
+       Err.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags)
+               "Simplifier statistics" (pprSimplCount counts)
+       dumpIfSet_dyn' logger dflags Opt_D_dump_simpl "Simplified expression"
+                      (ppr expr')
+#else
+       us <- mkSplitUniqSupply 'r'
        (expr', counts) <- initSmpl dflags emptyRuleEnv
                             emptyFamInstEnvs us sz
                             (simplExprGently (simplEnvForCcc dflags inline) expr)
        Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
                "Simplifier statistics" (pprSimplCount counts)
        dumpIfSet_dyn' dflags Opt_D_dump_simpl "Simplified expression"
                       (ppr expr')
+#endif
        return expr'
 
 -- Copied from SimplCore (not exported)
@@ -89,6 +112,24 @@ simplExprGently env expr = do
     simplExpr env (occurAnalyseExpr expr1)
 
 -- Like simplEnvForGHCi but with inlining.
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
+simplEnvForCcc :: DynFlags -> Bool -> Err.Logger -> SimplEnv
+simplEnvForCcc dflags inline logger
+  = mkSimplEnv $ SimplMode { sm_names = ["Simplify for ccc"]
+                           , sm_phase = Phase 0 -- Was InitialPhase
+                           , sm_rules = rules_on
+                           , sm_inline = inline -- was False
+                           , sm_eta_expand = eta_expand_on
+                           , sm_case_case = True
+                           , sm_uf_opts = defaultUnfoldingOpts
+                           , sm_pre_inline = inline
+                           , sm_logger = logger
+                           , sm_dflags = dflags
+                           }
+  where
+    rules_on      = gopt Opt_EnableRewriteRules   dflags
+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
+#else
 simplEnvForCcc :: DynFlags -> Bool -> SimplEnv
 simplEnvForCcc dflags inline
   = mkSimplEnv $ SimplMode { sm_names = ["Simplify for ccc"]
@@ -104,3 +145,4 @@ simplEnvForCcc dflags inline
   where
     rules_on      = gopt Opt_EnableRewriteRules   dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
+#endif