github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 17:04:47 +03:00
Code Issues Projects Releases Wiki Activity

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

Browse Source 
Upgrade to fused-effects v0.5.
This commit is contained in:
Rob Rix 2019-07-16 00:06:01 -05:00 committed by GitHub
commit f7111f138a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
52 changed files with 208 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
semantic-core/semantic-core.cabal
View File

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

1
semantic-core/src/Analysis/Eval.hs
View File

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

47
semantic-core/src/Control/Effect/Readline.hs
View File

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

1
semantic-core/src/Data/Core/Pretty.hs
View File

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

1
semantic-core/src/Data/Loc.hs
View File

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

12
semantic-core/src/Data/Name.hs
View File

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

4
semantic.cabal
View File

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

13
src/Analysis/Abstract/Graph.hs
View File

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

1
src/Control/Abstract/Context.hs
View File

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

1
src/Control/Abstract/Evaluator.hs
View File

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

6
src/Control/Abstract/Heap.hs
View File

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

13
src/Control/Abstract/Modules.hs
View File

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

1
src/Control/Abstract/PythonPackage.hs
View File

@ -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 (..))

4
src/Control/Abstract/ScopeGraph.hs
View File

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

118
src/Control/Abstract/Value.hs
View File

@ -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 }

26
src/Control/Effect/Interpose.hs
View File

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

8
src/Control/Effect/REPL.hs
View File

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

1
src/Data/Abstract/Address/Hole.hs
View File

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

1
src/Data/Abstract/Address/Monovariant.hs
View File

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

1
src/Data/Abstract/Address/Precise.hs
View File

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

1
src/Data/Abstract/Name.hs
View File

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

1
src/Data/Abstract/Value/Abstract.hs
View File

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

29
src/Data/Abstract/Value/Concrete.hs
View File

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

1
src/Data/Abstract/Value/Type.hs
View File

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

1
src/Data/Blob.hs
View File

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

1
src/Data/Graph.hs
View File

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

1
src/Data/Project.hs
View File

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

21
src/Diffing/Algorithm.hs
View File

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

2
src/Diffing/Interpreter.hs
View File

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

1
src/Language/JSON/PrettyPrint.hs
View File

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

1
src/Language/Python/PrettyPrint.hs
View File

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

2
src/Language/Ruby/PrettyPrint.hs
View File

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

1
src/Parsing/TreeSitter.hs
View File

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

2
src/Rendering/Graph.hs
View File

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

2
src/Reprinting/Translate.hs
View File

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

1
src/Semantic/AST.hs
View File

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

1
src/Semantic/Analysis.hs
View File

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

1
src/Semantic/Api/Diffs.hs
View File

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

1
src/Semantic/Api/Symbols.hs
View File

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

1
src/Semantic/Api/Terms.hs
View File

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

8
src/Semantic/Distribute.hs
View File

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

1
src/Semantic/Graph.hs
View File

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

8
src/Semantic/REPL.hs
View File

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

9
src/Semantic/Resolution.hs
View File

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

38
src/Semantic/Task.hs
View File

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

26
src/Semantic/Task/Files.hs
View File

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

9
src/Semantic/Telemetry.hs
View File

@ -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.

8
src/Semantic/Timeout.hs
View File

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

1
src/Semantic/Util.hs
View File

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

3
src/Tags/Tagging.hs
View File

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

1
test/Control/Abstract/Evaluator/Spec.hs
View File

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

1
test/SpecHelpers.hs
View File

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