diff --git a/polysemy-plugin/package.yaml b/polysemy-plugin/package.yaml index 49f5748..3f1160d 100644 --- a/polysemy-plugin/package.yaml +++ b/polysemy-plugin/package.yaml @@ -23,7 +23,6 @@ dependencies: - syb >= 0.7 && < 0.8 - transformers >= 0.5.2.0 && < 0.6 - containers >= 0.5 && < 0.7 -- type-errors >= 0.2 library: source-dirs: src diff --git a/polysemy-plugin/polysemy-plugin.cabal b/polysemy-plugin/polysemy-plugin.cabal index 150126c..4240c6e 100644 --- a/polysemy-plugin/polysemy-plugin.cabal +++ b/polysemy-plugin/polysemy-plugin.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: d8cd2995085b0503fd8a705c9adeb55802c4feebce00cf811bf71474bbceed1f +-- hash: 0e0346f075022fd1cff88b9ea55e939727cb9cff9d0c1f1cbb9741183e3eda5c name: polysemy-plugin version: 0.2.1.1 @@ -45,7 +45,6 @@ library , polysemy >=0.1 , syb >=0.7 && <0.8 , transformers >=0.5.2.0 && <0.6 - , type-errors >=0.2 default-language: Haskell2010 test-suite polysemy-plugin-test @@ -79,5 +78,4 @@ test-suite polysemy-plugin-test , should-not-typecheck >=2.1.0 && <3 , syb >=0.7 && <0.8 , transformers >=0.5.2.0 && <0.6 - , type-errors >=0.2 default-language: Haskell2010 diff --git a/polysemy-plugin/src/Polysemy/Plugin/Fundep.hs b/polysemy-plugin/src/Polysemy/Plugin/Fundep.hs index f959d8f..d99ebb2 100644 --- a/polysemy-plugin/src/Polysemy/Plugin/Fundep.hs +++ b/polysemy-plugin/src/Polysemy/Plugin/Fundep.hs @@ -65,7 +65,7 @@ data LookupState type family ThingOf (l :: LookupState) (a :: K.Type) :: K.Type where - ThingOf 'Locations _ = (String, String, String) + ThingOf 'Locations _ = (String, String) ThingOf 'Things a = a @@ -88,8 +88,8 @@ instance CanLookup TyCon where doLookup :: CanLookup a => ThingOf 'Locations a -> TcPluginM (ThingOf 'Things a) -doLookup (package, mdname, name) = do - md <- lookupModule (mkModuleName mdname) $ fsLit package +doLookup (mdname, name) = do + md <- lookupModule (mkModuleName mdname) $ fsLit "polysemy" nm <- lookupName md $ mkTcOcc name lookupStrategy nm @@ -104,10 +104,10 @@ lookupEverything (PolysemyStuff a b c d) = polysemyStuffLocations :: PolysemyStuff 'Locations polysemyStuffLocations = PolysemyStuff - { findClass = ("polysemy", "Polysemy.Internal.Union", "Find") - , semTyCon = ("polysemy", "Polysemy.Internal", "Sem") - , ifStuckTyCon = ("type-errors", "Type.Errors", "IfStuck") - , indexOfTyCon = ("polysemy", "Polysemy.Internal.Union", "IndexOf") + { findClass = ("Polysemy.Internal.Union", "Find") + , semTyCon = ("Polysemy.Internal", "Sem") + , ifStuckTyCon = ("Polysemy.Internal.CustomErrors.Redefined", "IfStuck") + , indexOfTyCon = ("Polysemy.Internal.Union", "IndexOf") } diff --git a/polysemy.cabal b/polysemy.cabal index d330874..dc0b523 100644 --- a/polysemy.cabal +++ b/polysemy.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 25e48329e5ee5f51e4a893420673166950aa3e236cad9156a38250ca0d782dc0 +-- hash: 43c0dbcf838e069641aed60c831928cae41286cc7ec30ca3db9077e9153a9cf4 name: polysemy version: 0.5.1.0 @@ -47,6 +47,7 @@ library Polysemy.Internal Polysemy.Internal.Combinators Polysemy.Internal.CustomErrors + Polysemy.Internal.CustomErrors.Redefined Polysemy.Internal.Fixpoint Polysemy.Internal.Forklift Polysemy.Internal.Kind diff --git a/src/Polysemy/Internal/CustomErrors.hs b/src/Polysemy/Internal/CustomErrors.hs index d1cde71..7c3f250 100644 --- a/src/Polysemy/Internal/CustomErrors.hs +++ b/src/Polysemy/Internal/CustomErrors.hs @@ -19,7 +19,8 @@ import Data.Kind import Fcf import GHC.TypeLits import Polysemy.Internal.Kind -import Type.Errors +import Polysemy.Internal.CustomErrors.Redefined +import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck) ------------------------------------------------------------------------------ diff --git a/src/Polysemy/Internal/CustomErrors/Redefined.hs b/src/Polysemy/Internal/CustomErrors/Redefined.hs new file mode 100644 index 0000000..9c7e5d4 --- /dev/null +++ b/src/Polysemy/Internal/CustomErrors/Redefined.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ConstraintKinds #-} + +------------------------------------------------------------------------------ +-- | This code is copied verbatim from 'Type.Errors' due to limitations in the +-- (GHC 8.6) plugin machinery. See +-- for more +-- info. +module Polysemy.Internal.CustomErrors.Redefined where + +import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck) + + +------------------------------------------------------------------------------ +-- | @'IfStuck' expr b c@ leaves @b@ in the residual constraints whenever +-- @expr@ is stuck, otherwise it 'Eval'uates @c@. +type family IfStuck (expr :: k) (b :: k1) (c :: Exp k1) :: k1 where + -- The type pattern @_ Foo@ is interpretered by the compiler as being of + -- any kind. This is great and exactly what we want here, except that things + -- like @forall s. Maybe s@ will get stuck on it. + -- + -- So instead, we just propagate out 100 of these type variables and assume + -- that 100 type variables ought to be enough for anyone. + IfStuck (_ AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind AnythingOfAnyKind AnythingOfAnyKind + AnythingOfAnyKind) b c = b + IfStuck a b c = Eval c + +data AnythingOfAnyKind + + +------------------------------------------------------------------------------ +-- | Like 'IfStuck', but specialized to the case when you don't want to do +-- anything if @expr@ isn't stuck. +type WhenStuck expr b = IfStuck expr b NoErrorFcf + + +------------------------------------------------------------------------------ +-- | Like 'IfStuck', but leaves no residual constraint when @expr@ is stuck. +-- This can be used to ensure an expression /isn't/ stuck before analyzing it +-- further. +type UnlessStuck expr c = IfStuck expr NoError c +