diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal index c76433713..f2800dbb9 100644 --- a/semantic-core/semantic-core.cabal +++ b/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 diff --git a/semantic-core/src/Analysis/Eval.hs b/semantic-core/src/Analysis/Eval.hs index e3f0c4b53..800fd62f5 100644 --- a/semantic-core/src/Analysis/Eval.hs +++ b/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 ((>=>)) diff --git a/semantic-core/src/Control/Effect/Readline.hs b/semantic-core/src/Control/Effect/Readline.hs index 0d76916eb..540e63d11 100644 --- a/semantic-core/src/Control/Effect/Readline.hs +++ b/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,7 +11,6 @@ module Control.Effect.Readline , ReadlineC (..) , runReadline , runReadlineWithHistory -, TransC (..) , ControlIOC (..) , runControlIO ) where @@ -19,38 +18,33 @@ module Control.Effect.Readline 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) diff --git a/semantic-core/src/Data/Core/Pretty.hs b/semantic-core/src/Data/Core/Pretty.hs index 022976907..fd4f03b2d 100644 --- a/semantic-core/src/Data/Core/Pretty.hs +++ b/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 diff --git a/semantic-core/src/Data/Loc.hs b/semantic-core/src/Data/Loc.hs index 9999f8a82..68df85d41 100644 --- a/semantic-core/src/Data/Loc.hs +++ b/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 diff --git a/semantic-core/src/Data/Name.hs b/semantic-core/src/Data/Name.hs index a3d1492fe..4ac617117 100644 --- a/semantic-core/src/Data/Name.hs +++ b/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) diff --git a/semantic.cabal b/semantic.cabal index 47d318db1..a1232c74a 100644 --- a/semantic.cabal +++ b/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 diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index bee2e2a02..4e24f6077 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/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 diff --git a/src/Control/Abstract/Context.hs b/src/Control/Abstract/Context.hs index 43ec632e4..076dcd2bd 100644 --- a/src/Control/Abstract/Context.hs +++ b/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 diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index e70c6d360..dafb2d7ee 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/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 diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 93be10db8..f15420be6 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -418,9 +418,9 @@ reachable roots heap = go mempty roots -- Effects data Deref value (m :: * -> *) k - = DerefCell (Set value) (Maybe value -> k) - | AssignCell value (Set value) (Set value -> k) - deriving stock Functor + = DerefCell (Set value) (Maybe value -> m k) + | AssignCell value (Set value) (Set value -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) runDeref :: Evaluator term address value (DerefC address value m) a diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 33c22cf54..b27ed8283 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -21,7 +21,6 @@ module Control.Abstract.Modules import Control.Abstract.Evaluator import Control.Effect.Carrier -import Control.Effect.Sum import Data.Abstract.BaseError import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable @@ -60,17 +59,17 @@ load path = sendModules (Load path pure) data Modules address value (m :: * -> *) k - = Load ModulePath (ModuleResult address value -> k) - | Lookup ModulePath (Maybe (ModuleResult address value) -> k) - | Resolve [FilePath] (Maybe ModulePath -> k) - | List FilePath ([ModulePath] -> k) - deriving stock Functor + = Load ModulePath (ModuleResult address value -> m k) + | Lookup ModulePath (Maybe (ModuleResult address value) -> m k) + | Resolve [FilePath] (Maybe ModulePath -> m k) + | List FilePath ([ModulePath] -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) sendModules :: ( Member (Modules address value) sig , Carrier sig m) - => Modules address value (Evaluator term address value m) (Evaluator term address value m return) + => Modules address value (Evaluator term address value m) return -> Evaluator term address value m return sendModules = send diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index dd9514907..c87952cc6 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -4,7 +4,6 @@ module Control.Abstract.PythonPackage import Control.Abstract as Abstract import Control.Effect.Carrier -import Control.Effect.Sum import Data.Abstract.Name (name) import Data.Abstract.Path (stripQuotes) import Data.Abstract.Value.Concrete (Value (..)) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 330ff03b5..ebf45a225 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -379,8 +379,8 @@ alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator te alloc = send . flip Alloc pure data Allocator address (m :: * -> *) k - = Alloc Name (address -> k) - deriving stock Functor + = Alloc Name (address -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) runAllocator :: Evaluator term address value (AllocatorC address m) a diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 07db76783..80cf1532e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -48,7 +48,11 @@ module Control.Abstract.Value , ObjectC(..) , runObject , runNumeric +, runNumericFunction +, runNumeric2Function , castToInteger +, runBitwiseFunction +, runBitwise2Function , liftBitwise , liftBitwise2 , unsignedRShift @@ -118,18 +122,18 @@ builtIn address = sendFunction . flip (BuiltIn address) pure call :: (Member (Function term address value) sig, Carrier sig m) => value -> [value] -> Evaluator term address value m value call fn args = sendFunction (Call fn args pure) -sendFunction :: (Member (Function term address value) sig, Carrier sig m) => Function term address value (Evaluator term address value m) (Evaluator term address value m a) -> Evaluator term address value m a +sendFunction :: (Member (Function term address value) sig, Carrier sig m) => Function term address value (Evaluator term address value m) a -> Evaluator term address value m a sendFunction = send bindThis :: (Member (Function term address value) sig, Carrier sig m) => value -> value -> Evaluator term address value m value bindThis this that = sendFunction (Bind this that pure) data Function term address value (m :: * -> *) k - = Function Name [Name] term address (value -> k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef. - | BuiltIn address BuiltIn (value -> k) -- ^ A built-in is parameterized by its parent scope, BuiltIn type, and returns a value. - | Call value [value] (value -> k) -- ^ A Call takes a set of values as parameters and returns a ValueRef. - | Bind value value (value -> k) - deriving stock Functor + = Function Name [Name] term address (value -> m k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef. + | BuiltIn address BuiltIn (value -> m k) -- ^ A built-in is parameterized by its parent scope, BuiltIn type, and returns a value. + | Call value [value] (value -> m k) -- ^ A Call takes a set of values as parameters and returns a ValueRef. + | Bind value value (value -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) @@ -154,9 +158,9 @@ ifthenelse :: (Member (Boolean value) sig, Carrier sig m) => value -> m a -> m a ifthenelse v t e = asBool v >>= \ c -> if c then t else e data Boolean value (m :: * -> *) k - = Boolean Bool (value -> k) - | AsBool value (Bool -> k) - deriving stock Functor + = Boolean Bool (value -> m k) + | AsBool value (Bool -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) runBoolean :: Evaluator term address value (BooleanC value m) a @@ -204,11 +208,11 @@ forLoop :: ( Carrier sig m forLoop initial cond step body = initial *> while cond (withLexicalScopeAndFrame body *> step) data While value m k - = While (m value) (m value) (value -> k) - deriving (Functor) + = While (m value) (m value) (value -> m k) + deriving stock (Functor, Generic1) instance HFunctor (While value) where - hmap f (While cond body k) = While (f cond) (f body) k + hmap f (While cond body k) = While (f cond) (f body) (f . k) runWhile :: Evaluator term address value (WhileC value m) a -> Evaluator term address value m a @@ -223,15 +227,9 @@ unit :: (Carrier sig m, Member (Unit value) sig) => Evaluator term address value unit = send (Unit pure) newtype Unit value (m :: * -> *) k - = Unit (value -> k) - deriving stock Functor - -instance HFunctor (Unit value) where - hmap _ = coerce - {-# INLINE hmap #-} - -instance Effect (Unit value) where - handle state handler (Unit k) = Unit (handler . (<$ state) . k) + = Unit (value -> m k) + deriving stock (Functor, Generic1) + deriving anyclass (HFunctor, Effect) runUnit :: Evaluator term address value (UnitC value m) a -> Evaluator term address value m a @@ -250,9 +248,9 @@ asString :: (Member (String value) sig, Carrier sig m) => value -> m Text asString v = send (AsString v pure) data String value (m :: * -> *) k - = String Text (value -> k) - | AsString value (Text -> k) - deriving stock Functor + = String Text (value -> m k) + | AsString value (Text -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) newtype StringC value m a = StringC { runStringC :: m a } @@ -281,7 +279,7 @@ liftNumeric :: (Member (Numeric value) sig, Carrier sig m) => (forall a . Num a => a -> a) -> value -> m value -liftNumeric t v = send (LiftNumeric t v pure) +liftNumeric t v = send (LiftNumeric (NumericFunction t) v pure) -- | Lift a pair of binary operators to a function on 'value's. -- You usually pass the same operator as both arguments, except in the cases where @@ -292,15 +290,25 @@ liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m) -> value -> value -> m value -liftNumeric2 t v1 v2 = send (LiftNumeric2 t v1 v2 pure) +liftNumeric2 t v1 v2 = send (LiftNumeric2 (Numeric2Function t) v1 v2 pure) + +data NumericFunction = NumericFunction (forall a . Num a => a -> a) + +runNumericFunction :: Num a => NumericFunction -> a -> a +runNumericFunction (NumericFunction f) a = f a + +data Numeric2Function = Numeric2Function (forall a b. Number a -> Number b -> SomeNumber) + +runNumeric2Function :: Numeric2Function -> Number a -> Number b -> SomeNumber +runNumeric2Function (Numeric2Function f) a b = f a b data Numeric value (m :: * -> *) k - = Integer Integer (value -> k) - | Float Scientific (value -> k) - | Rational Rational (value -> k) - | LiftNumeric (forall a . Num a => a -> a) value (value -> k) - | LiftNumeric2 (forall a b. Number a -> Number b -> SomeNumber) value value (value -> k) - deriving stock Functor + = Integer Integer (value -> m k) + | Float Scientific (value -> m k) + | Rational Rational (value -> m k) + | LiftNumeric NumericFunction value (value -> m k) + | LiftNumeric2 Numeric2Function value value (value -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) newtype NumericC value m a = NumericC { runNumericC :: m a } @@ -321,7 +329,7 @@ liftBitwise :: (Member (Bitwise value) sig, Carrier sig m) => (forall a . Bits a => a -> a) -> value -> m value -liftBitwise t v = send (LiftBitwise t v pure) +liftBitwise t v = send (LiftBitwise (BitwiseFunction t) v pure) -- | Lift a binary bitwise operator to values. The Integral constraint is -- necessary to satisfy implementation details of Haskell left/right shift, @@ -331,7 +339,7 @@ liftBitwise2 :: (Member (Bitwise value) sig, Carrier sig m) -> value -> value -> m value -liftBitwise2 t v1 v2 = send (LiftBitwise2 t v1 v2 pure) +liftBitwise2 t v1 v2 = send (LiftBitwise2 (Bitwise2Function t) v1 v2 pure) unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m) => value @@ -339,12 +347,22 @@ unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m) -> m value unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 pure) +data BitwiseFunction = BitwiseFunction (forall a . Bits a => a -> a) + +runBitwiseFunction :: Bits a => BitwiseFunction -> a -> a +runBitwiseFunction (BitwiseFunction f) a = f a + +data Bitwise2Function = Bitwise2Function (forall a . (Integral a, Bits a) => a -> a -> a) + +runBitwise2Function :: (Integral a, Bits a) => Bitwise2Function -> a -> a -> a +runBitwise2Function (Bitwise2Function f) a b = f a b + data Bitwise value (m :: * -> *) k - = CastToInteger value (value -> k) - | LiftBitwise (forall a . Bits a => a -> a) value (value -> k) - | LiftBitwise2 (forall a . (Integral a, Bits a) => a -> a -> a) value value (value -> k) - | UnsignedRShift value value (value -> k) - deriving stock Functor + = CastToInteger value (value -> m k) + | LiftBitwise BitwiseFunction value (value -> m k) + | LiftBitwise2 Bitwise2Function value value (value -> m k) + | UnsignedRShift value value (value -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) runBitwise :: Evaluator term address value (BitwiseC value m) a @@ -368,11 +386,11 @@ scopedEnvironment value = send (ScopedEnvironment value pure) klass :: (Member (Object address value) sig, Carrier sig m) => Declaration -> address -> m value klass d a = send (Klass d a pure) -data Object address value (m :: * -> *) k - = Object address (value -> k) - | ScopedEnvironment value (Maybe address -> k) - | Klass Declaration address (value -> k) - deriving stock Functor +data Object address value m k + = Object address (value -> m k) + | ScopedEnvironment value (Maybe address -> m k) + | Klass Declaration address (value -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) newtype ObjectC address value m a = ObjectC { runObjectC :: m a } @@ -391,9 +409,9 @@ asArray :: (Member (Array value) sig, Carrier sig m) => value -> m [value] asArray v = send (AsArray v pure) data Array value (m :: * -> *) k - = Array [value] (value -> k) - | AsArray value ([value] -> k) - deriving stock Functor + = Array [value] (value -> m k) + | AsArray value ([value] -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) newtype ArrayC value m a = ArrayC { runArrayC :: m a } @@ -413,9 +431,9 @@ kvPair :: (Member (Hash value) sig, Carrier sig m) => value -> value -> m value kvPair v1 v2 = send (KvPair v1 v2 pure) data Hash value (m :: * -> *) k - = Hash [(value, value)] (value -> k) - | KvPair value value (value -> k) - deriving stock Functor + = Hash [(value, value)] (value -> m k) + | KvPair value value (value -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) newtype HashC value m a = HashC { runHashC :: m a } diff --git a/src/Control/Effect/Interpose.hs b/src/Control/Effect/Interpose.hs index b3bd092cb..9be06cddd 100644 --- a/src/Control/Effect/Interpose.hs +++ b/src/Control/Effect/Interpose.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Interpose ( Interpose(..) , interpose @@ -10,15 +10,14 @@ module Control.Effect.Interpose import Control.Applicative import Control.Effect.Carrier import Control.Effect.Reader -import Control.Effect.Sum -data Interpose eff m k - = forall a . Interpose (m a) (forall n x . eff n (n x) -> m x) (a -> k) +data Interpose (eff :: (* -> *) -> * -> *) m k + = forall a . Interpose (m a) (forall n x . eff n x -> m x) (a -> m k) -deriving instance 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) k + hmap f (Interpose m h k) = Interpose (f m) (f . h) (f . k) -- | Respond to requests for some specific effect with a handler. -- @@ -27,7 +26,7 @@ instance HFunctor (Interpose eff) where -- Note that since 'Interpose' lacks an 'Effect' instance, only “pure” effects, i.e. effects which can be handled inside other effects using 'hmap' alone, can be run within the 'runInterpose' scope. This includes @Reader@, but not e.g. @State@ or @Error@. interpose :: (Member (Interpose eff) sig, Carrier sig m) => m a - -> (forall n x . eff n (n x) -> m x) + -> (forall n x . eff n x -> m x) -> m a interpose m f = send (Interpose m f pure) @@ -36,14 +35,15 @@ interpose m f = send (Interpose m f pure) runInterpose :: InterposeC eff m a -> m a runInterpose = runReader Nothing . runInterposeC -newtype InterposeC eff m a = InterposeC { runInterposeC :: ReaderC (Maybe (Listener eff (InterposeC eff m))) m a } - deriving (Alternative, Applicative, Functor, Monad) +newtype InterposeC (eff :: (* -> *) -> * -> *) m a = InterposeC + { runInterposeC :: ReaderC (Maybe (Listener eff (InterposeC eff m))) m a + } deriving (Alternative, Applicative, Functor, Monad) -newtype Listener eff m = Listener (forall n x . eff n (n x) -> m x) +newtype Listener (eff :: (* -> *) -> * -> *) m = Listener (forall n x . eff n x -> m x) --- TODO: Document the implementation of this, as it is extremely subtle. - -runListener :: Listener eff (InterposeC eff m) -> eff (InterposeC eff m) (InterposeC eff m a) -> InterposeC eff m a +-- Normally we can't just extract the existentials out of the Listener type. In this case, +-- we can constrain the foralled 'n' variable to be 'Interpose', which lets it by the typechecker. +runListener :: Listener eff (InterposeC eff m) -> eff (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 diff --git a/src/Control/Effect/REPL.hs b/src/Control/Effect/REPL.hs index 419fec08c..68a47a0ee 100644 --- a/src/Control/Effect/REPL.hs +++ b/src/Control/Effect/REPL.hs @@ -10,17 +10,15 @@ module Control.Effect.REPL import Prologue -import Control.Effect import Control.Effect.Carrier -import Control.Effect.Sum import Control.Effect.Reader import System.Console.Haskeline import qualified Data.Text as T data REPL (m :: * -> *) k - = Prompt Text (Maybe Text -> k) - | Output Text k - deriving stock Functor + = Prompt Text (Maybe Text -> m k) + | Output Text (m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text) diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index 7d82a1c7b..3ba7280e4 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -6,7 +6,6 @@ module Data.Abstract.Address.Hole import Control.Abstract import Control.Effect.Carrier -import Control.Effect.Sum import Prologue data Hole context a = Partial context | Total a diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index 5e2fc2337..12384a46c 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -5,7 +5,6 @@ module Data.Abstract.Address.Monovariant import Control.Abstract import Control.Effect.Carrier -import Control.Effect.Sum import Data.Abstract.Name import qualified Data.Set as Set import Prologue diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index 6e8892b0d..b68fc29d1 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -6,7 +6,6 @@ module Data.Abstract.Address.Precise import Control.Abstract import Control.Abstract.ScopeGraph (AllocatorC(..)) import Control.Effect.Carrier -import Control.Effect.Sum import qualified Data.Set as Set import Prologue diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 66d9bb4b2..a26012815 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -9,7 +9,6 @@ module Data.Abstract.Name , __self ) where -import Control.Effect import Control.Effect.Fresh import Data.Aeson import qualified Data.Char as Char diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 87a463484..cf49a826f 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -8,7 +8,6 @@ module Data.Abstract.Value.Abstract import Control.Abstract as Abstract import Control.Effect.Carrier -import Control.Effect.Sum import Data.Abstract.BaseError import Data.Abstract.Evaluatable import qualified Data.Map.Strict as Map diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index d9f9b6fbe..9f0799f5e 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -12,7 +12,6 @@ import qualified Control.Abstract as Abstract import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), Hash(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier import Control.Effect.Interpose -import Control.Effect.Sum import Data.Abstract.BaseError import Data.Abstract.Evaluatable (UnspecializedError(..), EvalError(..), Declarations) import Data.Abstract.FreeVariables @@ -226,20 +225,20 @@ instance ( Member (Reader ModuleInfo) sig Abstract.Float t k -> k (Float (Number.Decimal t)) Abstract.Rational t k -> k (Rational (Number.Ratio t)) Abstract.LiftNumeric f arg k -> k =<< case arg of - Integer (Number.Integer i) -> pure $ Integer (Number.Integer (f i)) - Float (Number.Decimal d) -> pure $ Float (Number.Decimal (f d)) - Rational (Number.Ratio r) -> pure $ Rational (Number.Ratio (f r)) + Integer (Number.Integer i) -> pure $ Integer (Number.Integer (runNumericFunction f i)) + Float (Number.Decimal d) -> pure $ Float (Number.Decimal (runNumericFunction f d)) + Rational (Number.Ratio r) -> pure $ Rational (Number.Ratio (runNumericFunction f r)) other -> throwBaseError (NumericError other) Abstract.LiftNumeric2 f left right k -> k =<< case (left, right) of - (Integer i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize - (Integer i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize - (Integer i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize - (Rational i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize - (Rational i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize - (Rational i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize - (Float i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize - (Float i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize - (Float i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize + (Integer i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize + (Integer i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize + (Integer i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize + (Rational i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize + (Rational i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize + (Rational i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize + (Float i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize + (Float i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize + (Float i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize _ -> throwBaseError (Numeric2Error left right) -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor @@ -268,9 +267,9 @@ instance ( Member (Reader ModuleInfo) sig CastToInteger (Integer (Number.Integer i)) k -> k (Integer (Number.Integer i)) CastToInteger (Float (Number.Decimal i)) k -> k (Integer (Number.Integer (coefficient (normalize i)))) CastToInteger i k -> throwBaseError (NumericError i) >>= k - LiftBitwise operator (Integer (Number.Integer i)) k -> k . Integer . Number.Integer . operator $ i + LiftBitwise operator (Integer (Number.Integer i)) k -> k . Integer . Number.Integer . runBitwiseFunction operator $ i LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= k - LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> k . Integer . Number.Integer $ operator i j + LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> k . Integer . Number.Integer $ runBitwise2Function operator i j LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= k UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j) UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= k diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 727c67b5b..5d887a06d 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -15,7 +15,6 @@ import Control.Abstract.ScopeGraph import qualified Control.Abstract as Abstract import Control.Abstract hiding (Boolean(..), Function(..), Numeric(..), Object(..), Array(..), Hash(..), String(..), Unit(..), While(..)) import Control.Effect.Carrier -import Control.Effect.Sum import Data.Abstract.BaseError import Data.Semigroup.Foldable (foldMap1) import qualified Data.Map as Map diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 2097a582f..b38db7d27 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -26,7 +26,6 @@ module Data.Blob import Prologue -import Control.Effect import Control.Effect.Error import Data.Aeson import qualified Data.ByteString.Lazy as BL diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs index 4cb0a4d02..9bdb25f54 100644 --- a/src/Data/Graph.hs +++ b/src/Data/Graph.hs @@ -20,7 +20,6 @@ import qualified Algebra.Graph.AdjacencyMap as A import Algebra.Graph.Class (connect, overlay, vertex) import qualified Algebra.Graph.Class as Class import qualified Algebra.Graph.ToGraph as Class -import Control.Effect import Control.Effect.State import Data.Aeson import qualified Data.Set as Set diff --git a/src/Data/Project.hs b/src/Data/Project.hs index e7cd935c2..d40033786 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -13,7 +13,6 @@ module Data.Project import Prelude hiding (readFile) import Prologue -import Control.Effect import Control.Effect.Error import Data.Blob import Data.Blob.IO diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index cb60957f3..ea23cb983 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -14,8 +14,8 @@ module Diffing.Algorithm , algorithmForTerms ) where -import Control.Effect hiding ((:+:)) -import Control.Effect.Carrier +import Control.Effect.Carrier hiding ((:+:)) +import Control.Effect.NonDet import qualified Data.Diff as Diff import Data.Sum import Data.Term @@ -25,20 +25,21 @@ import Prologue -- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm. data Diff term1 term2 diff (m :: * -> *) k -- | Diff two terms with the choice of algorithm left to the interpreter’s discretion. - = Diff term1 term2 (diff -> k) + = Diff term1 term2 (diff -> m k) -- | Diff two terms recursively in O(n) time, resulting in a single diff node. - | Linear term1 term2 (diff -> k) + | Linear term1 term2 (diff -> m k) -- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs. - | RWS [term1] [term2] ([diff] -> k) + | RWS [term1] [term2] ([diff] -> m k) -- | Delete a term. - | Delete term1 (diff -> k) + | Delete term1 (diff -> m k) -- | Insert a term. - | Insert term2 (diff -> k) + | Insert term2 (diff -> m k) -- | Replace one term with another. - | Replace term1 term2 (diff -> k) - deriving stock Functor + | Replace term1 term2 (diff -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) + newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a } deriving newtype (Applicative, Alternative, Functor, Monad) @@ -83,7 +84,7 @@ byInserting a2 = sendDiff (Insert a2 pure) byReplacing :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff byReplacing a1 a2 = send (Replace a1 a2 pure) -sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff m (m a) -> Algorithm term1 term2 diff m a +sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff m a -> Algorithm term1 term2 diff m a sendDiff = Algorithm . send diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index bd46e142d..aeb67c242 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -5,11 +5,9 @@ module Diffing.Interpreter , stripDiff ) where -import Control.Effect import Control.Effect.Carrier import Control.Effect.Cull import Control.Effect.NonDet -import Control.Effect.Sum import qualified Data.Diff as Diff import Data.Term import Diffing.Algorithm diff --git a/src/Language/JSON/PrettyPrint.hs b/src/Language/JSON/PrettyPrint.hs index 08b79beb7..44d59f4ff 100644 --- a/src/Language/JSON/PrettyPrint.hs +++ b/src/Language/JSON/PrettyPrint.hs @@ -8,7 +8,6 @@ module Language.JSON.PrettyPrint import Prologue -import Control.Effect import Control.Effect.Error import Streaming import qualified Streaming.Prelude as Streaming diff --git a/src/Language/Python/PrettyPrint.hs b/src/Language/Python/PrettyPrint.hs index bf0bf4b1c..66fa59739 100644 --- a/src/Language/Python/PrettyPrint.hs +++ b/src/Language/Python/PrettyPrint.hs @@ -2,7 +2,6 @@ module Language.Python.PrettyPrint ( printingPython ) where -import Control.Effect import Control.Effect.Error import Streaming import qualified Streaming.Prelude as Streaming diff --git a/src/Language/Ruby/PrettyPrint.hs b/src/Language/Ruby/PrettyPrint.hs index d2f5b6c2a..ed77d19fe 100644 --- a/src/Language/Ruby/PrettyPrint.hs +++ b/src/Language/Ruby/PrettyPrint.hs @@ -2,9 +2,7 @@ module Language.Ruby.PrettyPrint ( printingRuby ) where -import Control.Effect import Control.Effect.Error -import Control.Monad.Trans (lift) import Streaming import qualified Streaming.Prelude as Streaming diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index e1c53dd50..70e801e3c 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -7,7 +7,6 @@ module Parsing.TreeSitter import Prologue hiding (bracket) import qualified Control.Exception as Exc (bracket) -import Control.Effect import Control.Effect.Resource import Control.Effect.Trace import Data.ByteString.Unsafe (unsafeUseAsCStringLen) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 0f6dcac3f..c7a03bc08 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -8,8 +8,8 @@ module Rendering.Graph import Algebra.Graph.Export.Dot import Analysis.ConstructorName -import Control.Effect import Control.Effect.Fresh +import Control.Effect.Pure import Control.Effect.Reader import Control.Effect.State import Data.Diff diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index b354059e7..25a9b9733 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -5,8 +5,8 @@ module Reprinting.Translate , TranslatorC ) where -import Control.Effect import Control.Effect.Error +import Control.Effect.Pure import Control.Effect.State import Control.Monad import Streaming diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index 5045b04a9..46d293c82 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -12,7 +12,6 @@ import Prologue import Data.ByteString.Builder import Data.List (intersperse) -import Control.Effect import Control.Effect.Error import Data.AST import Data.Blob diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 9b01f737a..7b8fa3000 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -11,6 +11,7 @@ import qualified Data.Map.Strict as Map import Control.Abstract as Abstract import Control.Abstract.ScopeGraph (runAllocator) +import Control.Effect.Carrier import Control.Effect.Interpose import Data.Abstract.Evaluatable import Data.Abstract.Module diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 025d63af3..ae64f9a4e 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -13,7 +13,6 @@ module Semantic.Api.Diffs import Analysis.ConstructorName (ConstructorName) import Analysis.TOCSummary (HasDeclaration) -import Control.Effect import Control.Effect.Error import Control.Exception import Control.Lens diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index f72d099a7..f6df43db0 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -7,7 +7,6 @@ module Semantic.Api.Symbols import Prelude hiding (span) -import Control.Effect import Control.Effect.Error import Control.Exception import Control.Lens diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index b76bcb31a..fc8e58e7f 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -15,7 +15,6 @@ module Semantic.Api.Terms import Analysis.ConstructorName (ConstructorName) -import Control.Effect import Control.Effect.Error import Control.Lens import Control.Monad diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index be57768e1..af2c92098 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -10,10 +10,8 @@ module Semantic.Distribute ) where import qualified Control.Concurrent.Async as Async -import Control.Effect import Control.Effect.Carrier import Control.Effect.Reader -import Control.Effect.Sum import Control.Monad.IO.Unlift import Control.Parallel.Strategies import Prologue @@ -39,12 +37,12 @@ distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) -- | Distribute effects run tasks concurrently. data Distribute m k - = forall a . Distribute (m a) (a -> k) + = forall a . Distribute (m a) (a -> m k) -deriving instance Functor (Distribute m) +deriving instance Functor m => Functor (Distribute m) instance HFunctor Distribute where - hmap f (Distribute m k) = Distribute (f m) k + hmap f (Distribute m k) = Distribute (f m) (f . k) instance Effect Distribute where handle state handler (Distribute task k) = Distribute (handler (task <$ state)) (handler . fmap k) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 3d23df560..5eefd06b5 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -34,6 +34,7 @@ import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph import Control.Abstract hiding (String) import Control.Abstract.PythonPackage as PythonPackage +import Control.Effect.Carrier import Data.Abstract.Address.Hole as Hole import Data.Abstract.Address.Monovariant as Monovariant import Data.Abstract.Address.Precise as Precise diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 738942393..6044a7907 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -9,9 +9,9 @@ import Control.Abstract.ScopeGraph (runScopeError) import Control.Abstract.Heap (runHeapError) import Control.Effect.Carrier import Control.Effect.Catch -import Control.Effect.Resource -import Control.Effect.Sum +import Control.Effect.Lift import Control.Effect.REPL +import Control.Effect.Resource import Data.Abstract.Address.Precise as Precise import Data.Abstract.Evaluatable hiding (string) import Data.Abstract.Module @@ -60,8 +60,8 @@ repl proxy parser paths = withOptions debugOptions $ \config logger statter -> runM . withDistribute - . withCatch - . withResource + . runCatch + . runResource . withTimeout . runError @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 5fa83a67d..b625b0321 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -7,9 +7,7 @@ module Semantic.Resolution , ResolutionC(..) ) where -import Control.Effect import Control.Effect.Carrier -import Control.Effect.Sum import Data.Aeson import Data.Aeson.Types (parseMaybe) import Data.Blob @@ -18,6 +16,7 @@ import qualified Data.Map as Map import Data.Source import Data.Language import Prologue +import GHC.Generics (Generic1) import Semantic.Task.Files import System.FilePath.Posix @@ -44,9 +43,9 @@ resolutionMap Project{..} = case projectLanguage of _ -> send (NoResolution pure) data Resolution (m :: * -> *) k - = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k) - | NoResolution (Map FilePath FilePath -> k) - deriving stock Functor + = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> m k) + | NoResolution (Map FilePath FilePath -> m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) runResolution :: ResolutionC m a -> m a diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index be66a5554..94f8af9b9 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -22,7 +22,6 @@ module Semantic.Task , time' -- * High-level flow , parse -, analyze , decorate , diff , render @@ -58,20 +57,17 @@ module Semantic.Task import Analysis.Decorator (decoratorWithAlgebra) import qualified Assigning.Assignment as Assignment import qualified Assigning.Assignment.Deterministic as Deterministic -import qualified Control.Abstract as Analysis -import Control.Effect import Control.Effect.Carrier import Control.Effect.Catch import Control.Effect.Error +import Control.Effect.Lift import Control.Effect.Reader import Control.Effect.Resource -import Control.Effect.Sum import Control.Effect.Trace import Control.Monad import Control.Monad.IO.Class import Data.Blob import Data.ByteString.Builder -import Data.Coerce import Data.Diff import qualified Data.Error as Error import qualified Data.Flag as Flag @@ -119,13 +115,6 @@ parse :: (Member Task sig, Carrier sig m) -> m term parse parser blob = send (Parse parser blob pure) --- | A task running some 'Analysis.Evaluator' to completion. -analyze :: (Member Task sig, Carrier sig m) - => (Analysis.Evaluator term address value m a -> result) - -> Analysis.Evaluator term address value m a - -> m result -analyze interpret analysis = send (Analyze interpret analysis pure) - -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function. decorate :: (Functor f, Member Task sig, Carrier sig m) => RAlgebra (TermF f Location) (Term f Location) field @@ -169,8 +158,8 @@ runTask taskSession@TaskSession{..} task = do run = runM . withDistribute - . withCatch - . withResource + . runCatch + . runResource . withTimeout . runError . runTelemetry logger statter @@ -208,21 +197,23 @@ instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (Trace -- | An effect describing high-level tasks to be performed. data Task (m :: * -> *) k - = forall term . Parse (Parser term) Blob (term -> k) - | forall term address value m a result . Analyze (Analysis.Evaluator term address value m a -> result) (Analysis.Evaluator term address value m a) (result -> k) - | forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> k) - | forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> k) - | forall input output . Render (Renderer input output) input (output -> k) - | forall input . Serialize (Format input) input (Builder -> k) + = forall term . Parse (Parser term) Blob (term -> m k) + | forall f field . Functor f => Decorate (RAlgebra (TermF f Location) (Term f Location) field) (Term f Location) (Term f field -> m k) + | forall syntax ann . (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Diff (These (Term syntax ann) (Term syntax ann)) (Diff syntax ann ann -> m k) + | forall input output . Render (Renderer input output) input (output -> m k) + | forall input . Serialize (Format input) input (Builder -> m k) -deriving instance Functor (Task m) +deriving instance Functor m => Functor (Task m) instance HFunctor Task where - hmap _ = coerce + hmap f (Parse parser blob k) = Parse parser blob (f . k) + hmap f (Decorate decorator term k) = Decorate decorator term (f . k) + hmap f (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (f . k) + hmap f (Render renderer input k) = Render renderer input (f . k) + hmap f (Serialize format input k) = Serialize format input (f . k) instance Effect Task where handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k) - handle state handler (Analyze run analysis k) = Analyze run analysis (handler . (<$ state) . k) handle state handler (Decorate decorator term k) = Decorate decorator term (handler . (<$ state) . k) handle state handler (Semantic.Task.Diff terms k) = Semantic.Task.Diff terms (handler . (<$ state) . k) handle state handler (Render renderer input k) = Render renderer input (handler . (<$ state) . k) @@ -239,7 +230,6 @@ instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader eff (R other) = TaskC . eff . handleCoercible $ other eff (L op) = case op of Parse parser blob k -> runParser blob parser >>= k - Analyze interpret analysis k -> k . interpret $ analysis Decorate algebra term k -> k (decoratorWithAlgebra algebra term) Semantic.Task.Diff terms k -> k (diffTermPair terms) Render renderer input k -> k (renderer input) diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index 14a459967..dc2366e91 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -17,11 +17,9 @@ module Semantic.Task.Files , Excludes(..) ) where -import Control.Effect import Control.Effect.Carrier import Control.Effect.Catch import Control.Effect.Error -import Control.Effect.Sum import Data.Blob import Data.Blob.IO import qualified Data.ByteString.Builder as B @@ -50,14 +48,24 @@ data Excludes -- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's. data Files (m :: * -> *) k - = forall a . Read (Source a) (a -> k) - | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> k) - | FindFiles FilePath [String] [FilePath] ([FilePath] -> k) - | Write Destination B.Builder k + = forall a . Read (Source a) (a -> m k) + | ReadProject (Maybe FilePath) FilePath Language [FilePath] (Project -> m k) + | FindFiles FilePath [String] [FilePath] ([FilePath] -> m k) + | Write Destination B.Builder (m k) -deriving instance Functor (Files m) -instance HFunctor Files -instance Effect Files +deriving instance Functor m => Functor (Files m) + +instance HFunctor Files where + hmap f (Read s k) = Read s (f . k) + hmap f (ReadProject mp p l ps k) = ReadProject mp p l ps (f . k) + hmap f (FindFiles p s ps k) = FindFiles p s ps (f . k) + hmap f (Write d b k) = Write d b (f k) + +instance Effect Files where + handle state handler (Read s k) = Read s (handler . (<$ state) . k) + handle state handler (ReadProject mp p l ps k) = ReadProject mp p l ps (handler . (<$ state) . k) + handle state handler (FindFiles p s ps k) = FindFiles p s ps (handler . (<$ state) . k) + handle state handler (Write d b k) = Write d b (handler . (<$ state) $ k) -- | Run a 'Files' effect in 'IO' runFiles :: FilesC m a -> m a diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 089dcc31d..ee341289b 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -49,14 +49,13 @@ module Semantic.Telemetry , IgnoreTelemetryC(..) ) where -import Control.Effect import Control.Effect.Carrier import Control.Effect.Reader -import Control.Effect.Sum import Control.Exception import Control.Monad.IO.Class import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) import qualified Data.Time.LocalTime as LocalTime +import GHC.Generics (Generic1) import Semantic.Telemetry.AsyncQueue import Semantic.Telemetry.Error import Semantic.Telemetry.Log @@ -137,9 +136,9 @@ time' = withTiming' -- | Statting and logging effects. data Telemetry (m :: * -> *) k - = WriteStat Stat k - | WriteLog Level String [(String, String)] k - deriving stock Functor + = WriteStat Stat (m k) + | WriteLog Level String [(String, String)] (m k) + deriving stock (Functor, Generic1) deriving anyclass (HFunctor, Effect) -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs index 00d741041..773ccd4ed 100644 --- a/src/Semantic/Timeout.hs +++ b/src/Semantic/Timeout.hs @@ -8,10 +8,8 @@ module Semantic.Timeout , Duration(..) ) where -import Control.Effect import Control.Effect.Carrier import Control.Effect.Reader -import Control.Effect.Sum import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Data.Duration @@ -26,12 +24,12 @@ timeout n = send . flip (Timeout n) pure -- | 'Timeout' effects run other effects, aborting them if they exceed the -- specified duration. data Timeout m k - = forall a . Timeout Duration (m a) (Maybe a -> k) + = forall a . Timeout Duration (m a) (Maybe a -> m k) -deriving instance Functor (Timeout m) +deriving instance Functor m => Functor (Timeout m) instance HFunctor Timeout where - hmap f (Timeout n task k) = Timeout n (f task) k + hmap f (Timeout n task k) = Timeout n (f task) (f . k) instance Effect Timeout where handle state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just))) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e18511a73..d7dae435b 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -19,6 +19,7 @@ import Prelude hiding (readFile) import Control.Abstract import Control.Abstract.Heap (runHeapError) import Control.Abstract.ScopeGraph (runScopeError) +import Control.Effect.Lift import Control.Effect.Trace (runTraceByPrinting) import Control.Exception (displayException) import Data.Abstract.Address.Precise as Precise diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 9fd91cc06..8957e0424 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -8,8 +8,7 @@ where import Prelude hiding (fail, filter, log) import Prologue hiding (Element, hash) -import Control.Effect as Eff -import Control.Effect.State +import Control.Effect.State as Eff import Data.Text as T hiding (empty) import Streaming import qualified Streaming.Prelude as Streaming diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index c7f2d9359..9e583253f 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -6,6 +6,7 @@ module Control.Abstract.Evaluator.Spec import Control.Abstract as Abstract import qualified Control.Abstract.Heap as Heap +import Control.Effect.Lift import Data.Abstract.Address.Precise as Precise import Data.Abstract.BaseError import Data.Abstract.Evaluatable diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 443f0dc0b..459748cb7 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -23,6 +23,7 @@ import Control.Abstract import Data.Abstract.ScopeGraph (EdgeLabel(..)) import qualified Data.Abstract.ScopeGraph as ScopeGraph import qualified Data.Abstract.Heap as Heap +import Control.Effect.Lift import Control.Effect.Trace as X (runTraceByIgnoring, runTraceByReturning) import Control.Monad ((>=>)) import Data.Traversable as X (for)