Merge pull request #195 from github/upgrade-to-fused-effects-0.5

Upgrade to fused-effects v0.5.

Author: robrix

semantic-core/semantic-core.cabal

@@ -40,7 +40,7 @@ library
                      , containers                  ^>= 0.6
                      , directory                   ^>= 1.3
                      , filepath                    ^>= 1.4
-                     , fused-effects               ^>= 0.4
+                     , fused-effects               ^>= 0.5
                      , haskeline                   ^>= 0.7.5
                      , parsers                     ^>= 0.12.10
                      , prettyprinter               ^>= 1.2.1

semantic-core/src/Analysis/Eval.hs

@@ -11,7 +11,6 @@ module Analysis.Eval
 , Analysis(..)
 ) where
 
-import Control.Effect
 import Control.Effect.Fail
 import Control.Effect.Reader
 import Control.Monad ((>=>))

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

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, OverloadedStrings, RankNTypes, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, OverloadedStrings, RankNTypes, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
 
 module Control.Effect.Readline
 ( Readline (..)
@@ -11,46 +11,40 @@ module Control.Effect.Readline
 , ReadlineC (..)
 , runReadline
 , runReadlineWithHistory
-, TransC (..)
 , ControlIOC (..)
 , runControlIO
 ) where
 
 import Prelude hiding (print)
 
 import Control.Effect.Carrier
+import Control.Effect.Lift
 import Control.Effect.Reader
-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
 import Data.Text.Prettyprint.Doc.Render.Text
+import GHC.Generics (Generic1)
 import System.Console.Haskeline hiding (Handler, handle)
 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)
+  | Print AnyDoc (m k)
+  | AskLine (Line -> m k)
+  deriving stock (Functor, Generic1)
+  deriving anyclass (Effect, HFunctor)
 
-deriving instance Functor (Readline m)
-
-instance HFunctor Readline where
-  hmap _ = coerce
-
-instance Effect Readline where
-  handle state handler = coerce . fmap (handler . (<$ state))
+newtype AnyDoc = AnyDoc { unAnyDoc :: forall a . Doc a }
 
 prompt :: (IsString str, Member Readline sig, Carrier sig m) => String -> m (Maybe str)
 prompt p = fmap fromString <$> send (Prompt p pure)
 
 print :: (Pretty a, Carrier sig m, Member Readline sig) => a -> m ()
-print s = send (Print (pretty s) (pure ()))
+print s = send (Print (AnyDoc (pretty s)) (pure ()))
 
 println :: (Pretty a, Carrier sig m, Member Readline sig) => a -> m ()
 println s = print s >> print @String "\n"
@@ -63,19 +57,19 @@ newtype Line = Line Int64
 increment :: Line -> Line
 increment (Line n) = Line (n + 1)
 
-newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (TransC InputT m) a }
-  deriving (Applicative, Functor, Monad, MonadIO)
+newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (LiftC (InputT m)) a }
+  deriving newtype (Applicative, Functor, Monad, MonadIO)
 
 runReadline :: MonadException m => Prefs -> Settings m -> ReadlineC m a -> m a
-runReadline prefs settings = runInputTWithPrefs prefs settings . runTransC . runReader (Line 0) . runReadlineC
+runReadline prefs settings = runInputTWithPrefs prefs settings . runM . runReader (Line 0) . runReadlineC
 
-instance (Carrier sig m, Effect sig, MonadException m, MonadIO m) => Carrier (Readline :+: sig) (ReadlineC m) where
+instance (MonadException m, MonadIO m) => Carrier (Readline :+: Lift (InputT m)) (ReadlineC m) where
   eff (L (Prompt prompt k)) = ReadlineC $ do
-    str <- lift (TransC (getInputLine (cyan <> prompt <> plain)))
+    str <- lift (lift (getInputLine (cyan <> prompt <> plain)))
     local increment (runReadlineC (k str))
     where cyan = "\ESC[1;36m\STX"
           plain = "\ESC[0m\STX"
-  eff (L (Print text k)) = liftIO (putDoc text) *> k
+  eff (L (Print text k)) = liftIO (putDoc (unAnyDoc text)) *> k
   eff (L (AskLine k)) = ReadlineC ask >>= k
   eff (R other) = ReadlineC (eff (R (handleCoercible other)))
 
@@ -93,19 +87,12 @@ runReadlineWithHistory block = do
 
   runReadline prefs settings block
 
--- | Promote a monad transformer into an effect.
-newtype TransC t (m :: * -> *) a = TransC { runTransC :: t m a }
-  deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)
-
-instance (Carrier sig m, Effect sig, Monad (t m), MonadTrans t) => Carrier sig (TransC t m) where
-  eff = TransC . join . lift . eff . handle (pure ()) (pure . (runTransC =<<))
-
 runControlIO :: (forall x . m x -> IO x) -> ControlIOC m a -> m a
 runControlIO handler = runReader (Handler handler) . runControlIOC
 
 -- | This exists to work around the 'MonadException' constraint that haskeline entails.
 newtype ControlIOC m a = ControlIOC { runControlIOC :: ReaderC (Handler m) m a }
-  deriving (Applicative, Functor, Monad, MonadIO)
+  deriving newtype (Applicative, Functor, Monad, MonadIO)
 
 newtype Handler m = Handler (forall x . m x -> IO x)
 

semantic-core/src/Data/Core/Pretty.hs

@@ -8,7 +8,6 @@ module Data.Core.Pretty
   , prettyCore
   ) where
 
-import           Control.Effect
 import           Control.Effect.Reader
 import           Data.Core
 import           Data.File

semantic-core/src/Data/Loc.hs

@@ -15,7 +15,6 @@ import Control.Effect.Carrier
 import Control.Effect.Error
 import Control.Effect.Fail
 import Control.Effect.Reader
-import Control.Effect.Sum
 import Data.Text (Text, pack)
 import Data.Text.Prettyprint.Doc (Pretty (..))
 import GHC.Stack

semantic-core/src/Data/Name.hs

@@ -16,11 +16,9 @@ module Data.Name
 ) where
 
 import           Control.Applicative
-import           Control.Effect
 import           Control.Effect.Carrier
 import           Control.Effect.Reader
 import           Control.Effect.State
-import           Control.Effect.Sum
 import           Control.Monad.Fail
 import           Control.Monad.IO.Class
 import qualified Data.Char as Char
@@ -99,14 +97,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)

semantic.cabal

@@ -55,8 +55,8 @@ common dependencies
                      , fastsum ^>= 0.1.1.0
                      , filepath ^>= 1.4.2.1
                      , free ^>= 5.1
-                     , fused-effects ^>= 0.4.0.0
-                     , fused-effects-exceptions ^>= 0.1.1.0
+                     , fused-effects ^>= 0.5.0.0
+                     , fused-effects-exceptions ^>= 0.2.0.0
                      , hashable ^>= 1.2.7.0
                      , tree-sitter ^>= 0.1.0.0
                      , mtl ^>= 2.2.2

src/Analysis/Abstract/Graph.hs

@@ -19,7 +19,6 @@ module Analysis.Abstract.Graph
 import           Algebra.Graph.Export.Dot hiding (vertexName)
 import           Control.Abstract hiding (Function(..))
 import           Control.Effect.Carrier
-import           Control.Effect.Sum
 import           Data.Abstract.BaseError
 import           Data.Abstract.Declarations
 import           Data.Abstract.Module (Module (moduleInfo), ModuleInfo (..))
@@ -150,20 +149,20 @@ graphingModuleInfo recur m = do
     _             -> pure ()
 
 eavesdrop :: Evaluator term address value (EavesdropC address value m) a
-          -> (forall x . Modules address value m (m x) -> Evaluator term address value m ())
+          -> (forall x . Modules address value m x -> Evaluator term address value m ())
           -> Evaluator term address value m a
 eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f)) m
 
-newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m (m x) -> m ()) -> m a)
-  deriving (Alternative, Applicative, Functor, Monad) via (ReaderC (forall x . Modules address value m (m x) -> m ()) m)
+newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m x -> m ()) -> m a)
+  deriving (Alternative, Applicative, Functor, Monad) via (ReaderC (forall x . Modules address value m x -> m ()) m)
 
-runEavesdropC :: (forall x . Modules address value m (m x) -> m ()) -> EavesdropC address value m a -> m a
+runEavesdropC :: (forall x . Modules address value m x -> m ()) -> EavesdropC address value m a -> m a
 runEavesdropC f (EavesdropC m) = m f
 
 instance (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value m) where
   eff op
-    | Just eff <- prj op = EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff')
-    | otherwise          = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op))
+    | Just eff <- prj op = EavesdropC (\ handler -> let eff' = hmap (runEavesdropC handler) eff in handler eff' *> send eff')
+    | otherwise          = EavesdropC (\ handler -> eff (hmap (runEavesdropC handler) op))
 
 -- | Add an edge from the current package to the passed vertex.
 packageInclusion :: ( Member (Reader PackageInfo) sig

src/Control/Abstract/Context.hs

@@ -12,7 +12,6 @@ module Control.Abstract.Context
 , withCurrentCallStack
 ) where
 
-import Control.Effect
 import Control.Effect.Reader
 import Control.Effect.State
 import Data.Abstract.Module

src/Control/Abstract/Evaluator.hs

@@ -17,7 +17,6 @@ module Control.Abstract.Evaluator
   , module X
   ) where
 
-import Control.Effect as X
 import Control.Effect.Carrier
 import Control.Effect.Error as X
 import Control.Effect.Fresh as X