Support GHC 9.2

flake.lock

@@ -2,11 +2,11 @@
   "nodes": {
     "flake-utils": {
       "locked": {
-        "lastModified": 1618217525,
-        "narHash": "sha256-WGrhVczjXTiswQaoxQ+0PTfbLNeOQM6M36zvLn78AYg=",
+        "lastModified": 1637014545,
+        "narHash": "sha256-26IZAc5yzlD9FlDT54io1oqG/bBoyka+FJk5guaX4x4=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "c6169a2772643c4a93a0b5ac1c61e296cba68544",
+        "rev": "bba5dcc8e0b20ab664967ad83d24d64cb64ec4f4",
         "type": "github"
       },
       "original": {
@@ -15,36 +15,53 @@
         "type": "github"
       }
     },
+    "nixpkgs_2009": {
+      "locked": {
+        "lastModified": 1636935165,
+        "narHash": "sha256-J4smKTYTp8wJ57znUerWlS/QRgp0jcm/StcfIhsa5eA=",
+        "owner": "nixos",
+        "repo": "nixpkgs",
+        "rev": "f7949198dcff52265b322ca8abf7450610e7e49e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nixos",
+        "ref": "release-20.09",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs_2105": {
+      "locked": {
+        "lastModified": 1637497871,
+        "narHash": "sha256-UXjWFjZSQW56Ax2fKspG0aezeRmV7j4WAbkbnZpIFtk=",
+        "owner": "nixos",
+        "repo": "nixpkgs",
+        "rev": "d5c4e868ce3783a95bc1dd898777f09af7ff69ee",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nixos",
+        "ref": "release-21.05",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
     "root": {
       "inputs": {
         "flake-utils": "flake-utils",
-        "stable": "stable",
+        "nixpkgs_2009": "nixpkgs_2009",
+        "nixpkgs_2105": "nixpkgs_2105",
         "unstable": "unstable"
       }
     },
-    "stable": {
-      "locked": {
-        "lastModified": 1618441087,
-        "narHash": "sha256-NIuHLPxSNu5OXf9T/bY+pY7mgUVRdbFFjJfMUIM7CPw=",
-        "owner": "nixos",
-        "repo": "nixpkgs",
-        "rev": "389249fa9b35b3071b4ccf71a3c065e7791934df",
-        "type": "github"
-      },
-      "original": {
-        "owner": "nixos",
-        "ref": "nixos-20.09",
-        "repo": "nixpkgs",
-        "type": "github"
-      }
-    },
     "unstable": {
       "locked": {
-        "lastModified": 1618499499,
-        "narHash": "sha256-2DFWiEnI7JcgM3qKMTGEcq0VrsyutaYMDOCbCF7dDiA=",
+        "lastModified": 1637453606,
+        "narHash": "sha256-Gy6cwUswft9xqsjWxFYEnx/63/qzaFUwatcbV5GF/GQ=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "5268ee2ebacbc73875be42d71e60c2b5c1b5a1c7",
+        "rev": "8afc4e543663ca0a6a4f496262cd05233737e732",
         "type": "github"
       },
       "original": {

flake.nix

@@ -2,47 +2,51 @@
   description = "Higher-order, low-boilerplate free monads.";
 
   inputs = {
-    stable.url = github:nixos/nixpkgs/nixos-20.09;
+    nixpkgs_2009.url = github:nixos/nixpkgs/release-20.09;
+    nixpkgs_2105.url = github:nixos/nixpkgs/release-21.05;
     unstable.url = github:nixos/nixpkgs/nixpkgs-unstable;
     flake-utils.url = github:numtide/flake-utils;
   };
 
-  outputs = { stable, unstable, flake-utils, ... }:
+  outputs = { nixpkgs_2009, nixpkgs_2105, unstable, flake-utils, ... }:
   flake-utils.lib.eachSystem ["x86_64-linux"] (system:
+  with unstable.lib;
   let
     hsPkgs = nixpkgs: compiler: import ./nix/overlay.nix { inherit system nixpkgs compiler; };
 
-    ghc865 = hsPkgs stable "ghc865";
-    ghc884 = hsPkgs unstable "ghc884";
-    ghc8104 = hsPkgs unstable "ghc8104";
-    ghc901 = hsPkgs unstable "ghc901";
-
-    packages = {
-      inherit (ghc8104) polysemy polysemy-plugin;
-      polysemy-865 = ghc865.polysemy;
-      polysemy-plugin-865 = ghc865.polysemy-plugin;
-      polysemy-884 = ghc884.polysemy;
-      polysemy-plugin-884 = ghc884.polysemy-plugin;
-      polysemy-8104 = ghc8104.polysemy;
-      polysemy-plugin-8104 = ghc8104.polysemy-plugin;
-      polysemy-901 = ghc901.polysemy;
-      polysemy-plugin-901 = ghc901.polysemy-plugin;
+    ghcs = {
+      "865" = hsPkgs nixpkgs_2009 "ghc865";
+      "884" = hsPkgs nixpkgs_2105 "ghc884";
+      "8107" = hsPkgs unstable "ghc8107";
+      "901" = hsPkgs unstable "ghc901";
+      "921" = hsPkgs unstable "ghc921";
     };
-  in {
-    inherit packages;
 
-    defaultPackage = ghc8104.polysemy;
+    mkPackages = version: {
+      "polysemy-${version}" = ghcs.${version}.polysemy;
+      "polysemy-plugin-${version}" = ghcs.${version}.polysemy-plugin;
+    };
 
-    devShell = ghc8104.shellFor {
-      packages = _: [];
-      buildInputs = with ghc8104; [
+    packages =
+      foldl' (l: r: l // r) { inherit (ghcs."8107") polysemy polysemy-plugin; } (map mkPackages (attrNames ghcs));
+
+    mkDevShell = extra: ghc: ghc.shellFor {
+      packages = p: [p.polysemy p.polysemy-plugin];
+      buildInputs = with ghc; [
         cabal-install
-        haskell-language-server
-        ghcid
-      ];
-      withHoogle = true;
+      ] ++ (if extra then [ghcid haskell-language-server] else []);
+      withHoogle = extra;
     };
 
+    devShells = mapAttrs' (n: g: nameValuePair "ghc${n}" (mkDevShell (n != "921") g)) ghcs;
+
+  in {
+    inherit packages devShells;
+
+    defaultPackage = packages.polysemy;
+
+    devShell = devShells.ghc8107;
+
     checks = packages;
   });
 }

nix/overlay.nix

@@ -6,16 +6,32 @@
 let
   overrides = pkgs: self: super:
   let
+    inherit (builtins) splitVersion;
+    inherit (pkgs.lib) compare compareLists;
+    hs = pkgs.haskell.lib;
+    jailbreak = hs.doJailbreak;
+
     filter = pkgs.nix-gitignore.gitignoreSourcePure [./source-filter];
+
     c2n = name: src: pkgs.haskell.lib.disableLibraryProfiling (self.callCabal2nix name (filter src) {});
     hackage = pkg: ver: sha256: self.callHackageDirect { inherit pkg ver sha256; } {};
+
+    is92 = compareLists compare (splitVersion self.ghc.version) ["9" "2" "0"] >= 0;
+    if92 = n: f: if is92 then f n else n;
+
+    fcf = hackage "first-class-families" "0.8.0.1" "0h1rxbc7zsxrlhx5xcl58wjx3qi2wny8wb3sk7c1qnydf4ckcckz";
   in {
+    cabal-doctest =
+      if is92
+      then hackage "cabal-doctest" "1.0.9" "0irxfxy1qw7sif4408xdhqycddb4hs3hcf6xfxm65glsnmnmwl2i"
+      else super.cabal-doctest;
+    dump-core = hackage "dump-core" "0.1.3.2" "1mi8p736yn00z549pwnjv4ydwbs8mwg6dla3ly447c027nq8py6g";
+    first-class-families = if92 fcf jailbreak;
+    monadLib = hackage "monadLib" "3.10" "1v4ynjcb963s3lfw3v71qdzvld1mmz1faf8swhvicma5jbvwchy2";
     polysemy = c2n "polysemy" ../.;
     polysemy-plugin = c2n "polysemy-plugin" ../polysemy-plugin;
-    first-class-families =
-      hackage "first-class-families" "0.8.0.1" "0h1rxbc7zsxrlhx5xcl58wjx3qi2wny8wb3sk7c1qnydf4ckcckz";
-    dump-core = hackage "dump-core" "0.1.3.2" "1mi8p736yn00z549pwnjv4ydwbs8mwg6dla3ly447c027nq8py6g";
-    monadLib = hackage "monadLib" "3.10" "1v4ynjcb963s3lfw3v71qdzvld1mmz1faf8swhvicma5jbvwchy2";
+    primitive = if92 super.primitive jailbreak;
+    type-errors = if92 super.type-errors hs.dontCheck;
   };
 
   pkgs = import nixpkgs { inherit system; };

polysemy-plugin/src/Polysemy/Plugin/Fundep/Stuff.hs

@@ -13,9 +13,17 @@ import GHC.TcPluginM.Extra (lookupModule, lookupName)
 import GHC.Data.FastString (fsLit)
 import GHC.Types.Name.Occurrence (mkTcOcc)
 import GHC.Tc.Plugin (TcPluginM, tcLookupClass, tcLookupTyCon, unsafeTcPluginTcM)
-import GHC.Plugins (getDynFlags, unitState)
-import GHC.Unit.State (lookupModuleWithSuggestions, LookupResult (..))
-import GHC.Utils.Outputable (pprPanic, text, (<+>), ($$))
+import GHC.Plugins (getDynFlags)
+import GHC.Unit.State (lookupModuleWithSuggestions, LookupResult (..), UnitState)
+import GHC.Utils.Outputable (text, (<+>), ($$))
+#if __GLASGOW_HASKELL__ >= 902
+import GHC.Tc.Plugin (getTopEnv)
+import GHC.Utils.Panic (pprPanic)
+import GHC.Driver.Env (hsc_units)
+#else
+import GHC.Plugins (unitState)
+import GHC.Utils.Outputable(pprPanic)
+#endif
 #else
 import FastString (fsLit)
 import OccName (mkTcOcc)
@@ -45,13 +53,29 @@ polysemyStuffLocations = PolysemyStuff
   , semTyCon  = ("Polysemy.Internal",       "Sem")
   }
 
+#if __GLASGOW_HASKELL__ >= 900
+------------------------------------------------------------------------------
+-- | GHC-version-dependent access of the UnitState
+getUnitState :: TcPluginM UnitState
+getUnitState = do
+#if __GLASGOW_HASKELL__ >= 902
+  topState <- getTopEnv
+  return (hsc_units topState)
+#else
+  dflags <- unsafeTcPluginTcM getDynFlags
+  return (unitState dflags)
+#endif
+#endif
 
 ------------------------------------------------------------------------------
 -- | Lookup all of the 'PolysemyStuff'.
 polysemyStuff :: TcPluginM (PolysemyStuff 'Things)
 polysemyStuff = do
+#if __GLASGOW_HASKELL__ >= 900
+  theUnitState <- getUnitState
+#else
   dflags <- unsafeTcPluginTcM getDynFlags
-
+#endif
   let error_msg = pprPanic "polysemy-plugin"
           $ text ""
          $$ text "--------------------------------------------------------------------------------"
@@ -62,7 +86,7 @@ polysemyStuff = do
          $$ text ""
   case lookupModuleWithSuggestions
 #if __GLASGOW_HASKELL__ >= 900
-    (unitState dflags)
+    theUnitState
 #else
     dflags
 #endif

polysemy-plugin/src/Polysemy/Plugin/Fundep/Unification.hs

@@ -6,6 +6,7 @@ import           Data.Bool
 import           Data.Function (on)
 import           Data.Set (Set)
 import qualified Data.Set as S
+
 #if __GLASGOW_HASKELL__ >= 900
 import           GHC.Tc.Types.Constraint
 #elif __GLASGOW_HASKELL__ >= 810
@@ -72,17 +73,23 @@ unify solve_ctx = tryUnifyUnivarsButNotSkolems skolems
         InterpreterUse _ s -> s
         FunctionDef s      -> s
 
+#if __GLASGOW_HASKELL__ >= 902
+#define BINDME (const BindMe)
+#define APART (const Apart)
+#else
+#define BINDME BindMe
+#define APART Skolem
+#endif
 
 tryUnifyUnivarsButNotSkolems :: Set TyVar -> Type -> Type -> Maybe TCvSubst
 tryUnifyUnivarsButNotSkolems skolems goal inst =
   case tcUnifyTysFG
-         (bool BindMe Skolem . flip S.member skolems)
+         (bool BINDME APART . flip S.member skolems)
          [inst]
          [goal] of
     Unifiable subst -> pure subst
     _               -> Nothing
 
-
 ------------------------------------------------------------------------------
 -- | A wrapper for two types that we want to say have been unified.
 data Unification = Unification

polysemy-plugin/test/TypeErrors.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# LANGUAGE CPP #-}
 
 module TypeErrors where
 
@@ -38,6 +39,8 @@ missingFmap = ()
 -- ...
 insertAtUnprovidedIndex = ()
 
+#if __GLASGOW_HASKELL__ < 902
+
 --------------------------------------------------------------------------------
 -- |
 -- >>> :{
@@ -74,3 +77,5 @@ insertAtWrongIndex = ()
 -- ...e1 : State s : e3 : Reader i : e4 : r
 -- ...
 insertAtAndRaiseWrongIndex = ()
+
+#endif

src/Polysemy/Internal/CustomErrors.hs

@@ -36,31 +36,6 @@ infixr 4 %
 type family (%) (t :: k1) (b :: k2) :: ErrorMessage where
     t % b = ToErrorMessage t ':$$: ToErrorMessage b
 
--- TODO(sandy): Put in type-errors
-type ShowTypeBracketed t = "(" <> t <> ")"
-
-
-------------------------------------------------------------------------------
--- | The constructor of the effect row --- it's either completely polymorphic,
--- a nil, or a cons.
-data EffectRowCtor = TyVarR | NilR | ConsR
-
-
-------------------------------------------------------------------------------
--- | Given that @r@ isn't stuck, determine which constructor it has.
-type family UnstuckRState (r :: EffectRow) :: EffectRowCtor where
-  UnstuckRState '[]      = 'NilR
-  UnstuckRState (_ ': _) = 'ConsR
-
-
-------------------------------------------------------------------------------
--- | Put brackets around @r@ if it's a cons.
-type family ShowRQuoted (rstate :: EffectRowCtor) (r :: EffectRow) :: ErrorMessage where
-  ShowRQuoted 'TyVarR r = 'ShowType r
-  ShowRQuoted 'NilR   r = 'ShowType r
-  ShowRQuoted 'ConsR  r = ShowTypeBracketed r
-
-
 data FirstOrderErrorFcf :: k -> Symbol -> Exp Constraint
 type instance Eval (FirstOrderErrorFcf e fn) = $(te[t|
     UnlessPhantom

src/Polysemy/Internal/Index.hs

@@ -2,16 +2,17 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
 
 module Polysemy.Internal.Index where
 
 import GHC.TypeLits (Nat)
-import Type.Errors (TypeError, ErrorMessage(ShowType))
+import Type.Errors (ErrorMessage (ShowType), TypeError)
 
-import Polysemy.Internal.CustomErrors (type (<>), type (%))
-import Polysemy.Internal.Sing (SList (SEnd, SCons))
+import Polysemy.Internal.CustomErrors (type (%), type (<>))
+import Polysemy.Internal.Sing (SList (SCons, SEnd))
 
 ------------------------------------------------------------------------------
 -- | Infer a partition of the result type @full@ so that for the fixed segments
@@ -31,10 +32,17 @@ instance {-# INCOHERENT #-} (
     insertAtIndex = SCons (insertAtIndex @_ @index @head @tail @oldTail @full)
     {-# INLINE insertAtIndex #-}
 
+-- Broken on 9.2.
+-- It appears that instance matching is done with an abstract value for @oldTail@, thus not matching the correct
+-- instance and finding only this one, causing a false positive for the @TypeError@.
+#if __GLASGOW_HASKELL__ < 902
+
 instance {-# INCOHERENT #-} TypeError (InsertAtFailure index oldTail head full)
        => InsertAtIndex index head tail oldTail full inserted where
   insertAtIndex = error "unreachable"
 
+#endif
+
 type family InsertAtUnprovidedIndex where
   InsertAtUnprovidedIndex = TypeError (
     "insertAt: You must provide the index at which the effects should be inserted as a type application."