Redefine Type.Errors directly in polysemy (#153)

Fixes #152

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

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

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")
   }
 
 

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

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)
 
 
 ------------------------------------------------------------------------------

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
+-- <https://github.com/polysemy-research/polysemy/issues/152 #152> 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
+