diff --git a/flake.lock b/flake.lock index 493e792..65d2b3f 100644 --- a/flake.lock +++ b/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": { diff --git a/flake.nix b/flake.nix index 323efea..147b474 100644 --- a/flake.nix +++ b/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; }); } diff --git a/nix/overlay.nix b/nix/overlay.nix index 457688c..0675540 100644 --- a/nix/overlay.nix +++ b/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; }; diff --git a/polysemy-plugin/src/Polysemy/Plugin/Fundep/Stuff.hs b/polysemy-plugin/src/Polysemy/Plugin/Fundep/Stuff.hs index 85d1d72..ea06c63 100644 --- a/polysemy-plugin/src/Polysemy/Plugin/Fundep/Stuff.hs +++ b/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 diff --git a/polysemy-plugin/src/Polysemy/Plugin/Fundep/Unification.hs b/polysemy-plugin/src/Polysemy/Plugin/Fundep/Unification.hs index 0829bac..a8a14b9 100644 --- a/polysemy-plugin/src/Polysemy/Plugin/Fundep/Unification.hs +++ b/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 diff --git a/polysemy-plugin/test/TypeErrors.hs b/polysemy-plugin/test/TypeErrors.hs index 4fddab6..d783864 100644 --- a/polysemy-plugin/test/TypeErrors.hs +++ b/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 diff --git a/src/Polysemy/Internal/CustomErrors.hs b/src/Polysemy/Internal/CustomErrors.hs index fd9e488..e4d3406 100644 --- a/src/Polysemy/Internal/CustomErrors.hs +++ b/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 diff --git a/src/Polysemy/Internal/Index.hs b/src/Polysemy/Internal/Index.hs index f4ebe3c..9c5481e 100644 --- a/src/Polysemy/Internal/Index.hs +++ b/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."