Fix effects in semantic-core.

Author: Patrick Thomson

semantic-core/src/Control/Effect/Readline.hs

@@ -24,7 +24,6 @@ import Control.Effect.Sum
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
-import Data.Coerce
 import Data.Int
 import Data.String
 import Data.Text.Prettyprint.Doc
@@ -34,17 +33,17 @@ import System.Directory
 import System.FilePath
 
 data Readline (m :: * -> *) k
-  = Prompt String (Maybe String -> k)
-  | forall a . Print (Doc a) k
-  | AskLine (Line -> k)
+  = Prompt String (Maybe String -> m k)
+  | forall a . Print (Doc a) (m k)
+  | AskLine (Line -> m k)
 
-deriving instance Functor (Readline m)
+deriving instance Functor m => Functor (Readline m)
 
 instance HFunctor Readline where
-  hmap _ = coerce
+  hmap f (Prompt s k) = Prompt s (f . k)
+  hmap f (Print d k) = Print d (f k)
+  hmap f (AskLine k) = AskLine (f . k)
 
-instance Effect Readline where
-  handle state handler = coerce . fmap (handler . (<$ state))
 
 prompt :: (IsString str, Member Readline sig, Carrier sig m) => String -> m (Maybe str)
 prompt p = fmap fromString <$> send (Prompt p pure)

semantic-core/src/Data/Name.hs

@@ -99,14 +99,14 @@ namespace s m = send (Namespace s m pure)
 
 
 data Naming m k
-  = Gensym Text (Gensym -> k)
-  | forall a . Namespace Text (m a) (a -> k)
+  = Gensym Text (Gensym -> m k)
+  | forall a . Namespace Text (m a) (a -> m k)
 
-deriving instance Functor (Naming m)
+deriving instance Functor m => Functor (Naming m)
 
 instance HFunctor Naming where
-  hmap _ (Gensym    s   k) = Gensym    s       k
-  hmap f (Namespace s m k) = Namespace s (f m) k
+  hmap f (Gensym    s   k) = Gensym    s       (f . k)
+  hmap f (Namespace s m k) = Namespace s (f m) (f . k)
 
 instance Effect Naming where
   handle state handler (Gensym    s   k) = Gensym    s                        (handler . (<$ state) . k)

src/Control/Effect/Interpose.hs

@@ -15,10 +15,10 @@ import Control.Effect.Sum
 data Interpose (eff :: (* -> *) -> * -> *) m k
   = forall a . Interpose (m a) (forall n x . eff n x -> m x) (a -> m k)
 
--- deriving instance Functor m => Functor (Interpose eff m)
+deriving instance Functor m => Functor (Interpose eff m)
 
--- instance HFunctor (Interpose eff) where
---   hmap f (Interpose m h k) = Interpose (f m) (f . h) (f . k)
+instance HFunctor (Interpose eff) where
+  hmap f (Interpose m h k) = Interpose (f m) (f . h) (f . k)
 
 -- | Respond to requests for some specific effect with a handler.
 --
@@ -47,11 +47,12 @@ newtype Listener (eff :: (* -> *) -> * -> *) m = Listener (forall n x . eff n x
 -- runListener :: Listener eff (InterposeC eff m) -> eff (InterposeC eff m) (InterposeC eff m a) -> InterposeC eff m a
 -- runListener (Listener listen) = listen
 
--- instance (Carrier sig m, Member eff sig) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
---   eff (L (Interpose m h k)) =
---     InterposeC (local (const (Just (Listener h))) (runInterposeC m)) >>= _ k
---   eff (R other) = do
---     listener <- InterposeC ask
---     case (listener, prj other) of
---       (Just listener, Just eff) -> runListener listener eff
---       _                         -> InterposeC (eff (R (handleCoercible other)))
+instance (Carrier sig m, Member eff sig) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where
+  eff = undefined
+  -- eff (L (Interpose m h k)) =
+  --   InterposeC (local (const (Just (Listener h))) (runInterposeC m)) >>= _ k
+  -- eff (R other) = do
+  --   listener <- InterposeC ask
+  --   case (listener, prj other) of
+  --     (Just listener, Just eff) -> runListener listener eff
+  --     _                         -> InterposeC (eff (R (handleCoercible other)))

src/Semantic/REPL.hs

@@ -61,7 +61,7 @@ repl proxy parser paths =
     runM
     . withDistribute
     . withCatch
-    . withResource
+    . runResource
     . withTimeout
     . runError @SomeException
     . runTelemetryIgnoringStat (logOptionsFromConfig config)