diff --git a/cabal.project b/cabal.project index 7ccdec9aa..db018f11a 100644 --- a/cabal.project +++ b/cabal.project @@ -41,4 +41,4 @@ source-repository-package source-repository-package type: git location: https://github.com/antitypical/fused-syntax.git - tag: 6b412694e64cc275ed06513b3c360f03bb1f04fd + tag: d11e14581217590a5c67f79cbaeee35ac8acee6a diff --git a/semantic-analysis/semantic-analysis.cabal b/semantic-analysis/semantic-analysis.cabal index cb77bf035..e7d4789e1 100644 --- a/semantic-analysis/semantic-analysis.cabal +++ b/semantic-analysis/semantic-analysis.cabal @@ -54,7 +54,7 @@ library algebraic-graphs ^>= 0.3 , base >= 4.12 && < 5 , containers ^>= 0.6 - , fused-effects ^>= 0.5 + , fused-effects ^>= 1.0 , fused-syntax , haskeline ^>= 0.7.5 , pathtype ^>= 0.8.1 diff --git a/semantic-analysis/src/Analysis/Concrete.hs b/semantic-analysis/src/Analysis/Concrete.hs index 61fd29761..26c3c072b 100644 --- a/semantic-analysis/src/Analysis/Concrete.hs +++ b/semantic-analysis/src/Analysis/Concrete.hs @@ -13,13 +13,13 @@ import qualified Algebra.Graph as G import qualified Algebra.Graph.Export.Dot as G import Analysis.Analysis import Analysis.File +import Control.Algebra import Control.Applicative (Alternative (..)) import Control.Carrier.Fail.WithLoc -import Control.Effect -import Control.Effect.Fresh -import Control.Effect.NonDet -import Control.Effect.Reader hiding (Local) -import Control.Effect.State +import Control.Carrier.Fresh.Strict +import Control.Carrier.NonDet.Church +import Control.Carrier.Reader hiding (Local) +import Control.Carrier.State.Strict import Control.Monad ((<=<), guard) import Data.Function (fix) import qualified Data.IntMap as IntMap @@ -73,7 +73,7 @@ concrete , Show (term name) ) => (forall sig m - . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) + . (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m, MonadFail m) => Analysis term name Precise (Concrete term name) m -> (term name -> m (Concrete term name)) -> (term name -> m (Concrete term name)) @@ -82,24 +82,23 @@ concrete -> (Heap term name, [File (Either (Path.AbsRelFile, Span, String) (Concrete term name))]) concrete eval = run - . runFresh + . evalFresh 0 . runHeap . traverse (runFile eval) runFile :: forall term name m sig - . ( Carrier sig m - , Effect sig + . ( Effect sig , Foldable term , IsString name - , Member Fresh sig - , Member (State (Heap term name)) sig + , Has Fresh sig m + , Has (State (Heap term name)) sig m , Ord name , Show name , Show (term name) ) => (forall sig m - . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) + . (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m, MonadFail m) => Analysis term name Precise (Concrete term name) m -> (term name -> m (Concrete term name)) -> (term name -> m (Concrete term name)) @@ -113,20 +112,20 @@ runFile eval file = traverse run file . runReader @(Env name) mempty . fix (eval concreteAnalysis) -concreteAnalysis :: ( Carrier sig m - , Foldable term - , IsString name - , Member Fresh sig - , Member (Reader (Env name)) sig - , Member (Reader Path.AbsRelFile) sig - , Member (Reader Span) sig - , Member (State (Heap term name)) sig - , MonadFail m - , Ord name - , Show name - , Show (term name) - ) - => Analysis term name Precise (Concrete term name) m +concreteAnalysis + :: ( Foldable term + , IsString name + , Has Fresh sig m + , Has (Reader (Env name)) sig m + , Has (Reader Path.AbsRelFile) sig m + , Has (Reader Span) sig m + , Has (State (Heap term name)) sig m + , MonadFail m + , Ord name + , Show name + , Show (term name) + ) + => Analysis term name Precise (Concrete term name) m concreteAnalysis = Analysis{..} where alloc _ = fresh bind name addr m = local (Map.insert name addr) m @@ -164,7 +163,7 @@ concreteAnalysis = Analysis{..} lookupConcrete :: (IsString name, Ord name) => Heap term name -> name -> Concrete term name -> Maybe Precise -lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete +lookupConcrete heap name = run . evalState IntSet.empty . runNonDetA . inConcrete where -- look up the name in a concrete value inConcrete = inFrame <=< maybeA . recordFrame -- look up the name in a specific 'Frame', with slots taking precedence over parents diff --git a/semantic-analysis/src/Analysis/FlowInsensitive.hs b/semantic-analysis/src/Analysis/FlowInsensitive.hs index 0240d6739..bb744194c 100644 --- a/semantic-analysis/src/Analysis/FlowInsensitive.hs +++ b/semantic-analysis/src/Analysis/FlowInsensitive.hs @@ -2,20 +2,20 @@ module Analysis.FlowInsensitive ( Heap , FrameId(..) +, Cache , convergeTerm , cacheTerm , runHeap , foldMapA ) where -import Control.Effect -import Control.Effect.Fresh -import Control.Effect.NonDet -import Control.Effect.Reader -import Control.Effect.State +import Control.Algebra +import Control.Carrier.Fresh.Strict +import Control.Carrier.NonDet.Church +import Control.Carrier.Reader +import Control.Carrier.State.Strict import qualified Data.Map as Map import Data.Maybe (fromMaybe) -import Data.Monoid (Alt(..)) import qualified Data.Set as Set newtype Cache term a = Cache { unCache :: Map.Map term (Set.Set a) } @@ -28,30 +28,29 @@ newtype FrameId name = FrameId { unFrameId :: name } convergeTerm :: forall m sig a term address proxy - . ( Carrier sig m - , Effect sig + . ( Effect sig , Eq address - , Member Fresh sig - , Member (State (Heap address a)) sig + , Has Fresh sig m + , Has (State (Heap address a)) sig m , Ord a , Ord term ) => proxy address - -> (term -> NonDetC (ReaderC (Cache term a) (StateC (Cache term a) m)) a) + -> Int + -> (term -> NonDetC (FreshC (ReaderC (Cache term a) (StateC (Cache term a) m))) a) -> term -> m (Set.Set a) -convergeTerm _ eval body = do +convergeTerm _ n eval body = do heap <- get (cache, _) <- converge (Cache Map.empty :: Cache term a, heap :: Heap address a) $ \ (prevCache, _) -> runState (Cache Map.empty) . runReader prevCache $ do - _ <- resetFresh . runNonDetM Set.singleton $ eval body + _ <- runFresh n . runNonDetM Set.singleton $ eval body get pure (fromMaybe mempty (Map.lookup body (unCache cache))) cacheTerm :: forall m sig a term . ( Alternative m - , Carrier sig m - , Member (Reader (Cache term a)) sig - , Member (State (Cache term a)) sig + , Has (Reader (Cache term a)) sig m + , Has (State (Cache term a)) sig m , Ord a , Ord term ) @@ -70,13 +69,6 @@ cacheTerm eval term = do runHeap :: StateC (Heap address a) m b -> m (Heap address a, b) runHeap m = runState Map.empty m --- | Fold a collection by mapping each element onto an 'Alternative' action. -foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a -foldMapA f = getAlt . foldMap (Alt . f) - -runNonDetM :: (Monoid b, Applicative m) => (a -> b) -> NonDetC m a -> m b -runNonDetM f (NonDetC m) = m (fmap . (<>) . f) (pure mempty) - -- | Iterate a monadic action starting from some initial seed until the results converge. -- -- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem diff --git a/semantic-analysis/src/Analysis/ImportGraph.hs b/semantic-analysis/src/Analysis/ImportGraph.hs index aebab99c7..88a3082b6 100644 --- a/semantic-analysis/src/Analysis/ImportGraph.hs +++ b/semantic-analysis/src/Analysis/ImportGraph.hs @@ -9,11 +9,11 @@ import Analysis.Analysis import Analysis.File import Analysis.FlowInsensitive import Control.Applicative (Alternative(..)) +import Control.Algebra import Control.Carrier.Fail.WithLoc -import Control.Effect -import Control.Effect.Fresh -import Control.Effect.Reader -import Control.Effect.State +import Control.Carrier.Fresh.Strict +import Control.Carrier.Reader +import Control.Carrier.State.Strict import Control.Monad ((>=>)) import Data.Foldable (fold, for_) import Data.Function (fix) @@ -51,7 +51,7 @@ data Semi term name importGraph :: (Ord name, Ord (term name), Show name, Show (term name)) => (forall sig m - . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) + . (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m, MonadFail m) => Analysis term name name (Value term name) m -> (term name -> m (Value term name)) -> (term name -> m (Value term name)) @@ -62,23 +62,22 @@ importGraph ) importGraph eval = run - . runFresh + . evalFresh 0 . runHeap . traverse (runFile eval) runFile :: forall term name m sig - . ( Carrier sig m - , Effect sig - , Member Fresh sig - , Member (State (Heap name (Value term name))) sig + . ( Effect sig + , Has Fresh sig m + , Has (State (Heap name (Value term name))) sig m , Ord name , Ord (term name) , Show name , Show (term name) ) => (forall sig m - . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) + . (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m, MonadFail m) => Analysis term name name (Value term name) m -> (term name -> m (Value term name)) -> (term name -> m (Value term name)) @@ -90,14 +89,13 @@ runFile eval file = traverse run file . runReader (fileSpan file) . runFail . fmap fold - . convergeTerm (Proxy @name) (fix (cacheTerm . eval importGraphAnalysis)) + . convergeTerm (Proxy @name) 0 (fix (cacheTerm . eval importGraphAnalysis)) -- FIXME: decompose into a product domain and two atomic domains importGraphAnalysis :: ( Alternative m - , Carrier sig m - , Member (Reader Path.AbsRelFile) sig - , Member (Reader Span) sig - , Member (State (Heap name (Value term name))) sig + , Has (Reader Path.AbsRelFile) sig m + , Has (Reader Span) sig m + , Has (State (Heap name (Value term name))) sig m , MonadFail m , Ord name , Ord (term name) diff --git a/semantic-analysis/src/Analysis/ScopeGraph.hs b/semantic-analysis/src/Analysis/ScopeGraph.hs index cf97aaa5b..58e93c5b7 100644 --- a/semantic-analysis/src/Analysis/ScopeGraph.hs +++ b/semantic-analysis/src/Analysis/ScopeGraph.hs @@ -10,11 +10,11 @@ module Analysis.ScopeGraph import Analysis.Analysis import Analysis.File import Analysis.FlowInsensitive +import Control.Algebra import Control.Applicative (Alternative (..)) +import Control.Carrier.Reader import Control.Carrier.Fail.WithLoc -import Control.Effect.Carrier -import Control.Effect.Fresh -import Control.Effect.Reader +import Control.Carrier.Fresh.Strict import Control.Effect.State import Control.Monad ((>=>)) import Data.Foldable (fold) @@ -53,7 +53,7 @@ instance Ord name => Monoid (ScopeGraph name) where scopeGraph :: (Ord name, Ord (term name)) => (forall sig m - . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) + . (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m, MonadFail m) => Analysis term name name (ScopeGraph name) m -> (term name -> m (ScopeGraph name)) -> (term name -> m (ScopeGraph name)) @@ -62,21 +62,20 @@ scopeGraph -> (Heap name (ScopeGraph name), [File (Either (Path.AbsRelFile, Span, String) (ScopeGraph name))]) scopeGraph eval = run - . runFresh + . evalFresh 0 . runHeap . traverse (runFile eval) runFile :: forall term name m sig - . ( Carrier sig m - , Effect sig - , Member Fresh sig - , Member (State (Heap name (ScopeGraph name))) sig + . ( Effect sig + , Has Fresh sig m + , Has (State (Heap name (ScopeGraph name))) sig m , Ord name , Ord (term name) ) => (forall sig m - . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) + . (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m, MonadFail m) => Analysis term name name (ScopeGraph name) m -> (term name -> m (ScopeGraph name)) -> (term name -> m (ScopeGraph name)) @@ -89,15 +88,14 @@ runFile eval file = traverse run file . runReader (Map.empty @name @Ref) . runFail . fmap fold - . convergeTerm (Proxy @name) (fix (cacheTerm . eval scopeGraphAnalysis)) + . convergeTerm (Proxy @name) 0 (fix (cacheTerm . eval scopeGraphAnalysis)) scopeGraphAnalysis :: ( Alternative m - , Carrier sig m - , Member (Reader Path.AbsRelFile) sig - , Member (Reader Span) sig - , Member (Reader (Map.Map name Ref)) sig - , Member (State (Heap name (ScopeGraph name))) sig + , Has (Reader Path.AbsRelFile) sig m + , Has (Reader Span) sig m + , Has (Reader (Map.Map name Ref)) sig m + , Has (State (Heap name (ScopeGraph name))) sig m , Ord name ) => Analysis term name name (ScopeGraph name) m diff --git a/semantic-analysis/src/Analysis/Typecheck.hs b/semantic-analysis/src/Analysis/Typecheck.hs index 07b924560..3f38575b9 100644 --- a/semantic-analysis/src/Analysis/Typecheck.hs +++ b/semantic-analysis/src/Analysis/Typecheck.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DeriveTraversable, DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, QuantifiedConstraints, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators #-} +{-# LANGUAGE DeriveGeneric, DeriveTraversable, DerivingVia, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Analysis.Typecheck ( Monotype (..) , Meta @@ -10,12 +10,12 @@ module Analysis.Typecheck import Analysis.Analysis import Analysis.File import Analysis.FlowInsensitive +import Control.Algebra import Control.Applicative (Alternative (..)) import Control.Carrier.Fail.WithLoc -import Control.Effect.Carrier -import Control.Effect.Fresh as Fresh -import Control.Effect.Reader hiding (Local) -import Control.Effect.State +import Control.Carrier.Fresh.Strict as Fresh +import Control.Carrier.Reader hiding (Local) +import Control.Carrier.State.Strict import Control.Monad ((>=>), unless) import Data.Foldable (for_) import Data.Function (fix) @@ -60,32 +60,30 @@ deriving instance (Ord name, Ord a, forall a . Eq a => Eq (f a) deriving instance (Show name, Show a, forall a . Show a => Show (f a)) => Show (Monotype name f a) instance HFunctor (Monotype name) + instance RightModule (Monotype name) where - Unit >>=* _ = Unit - Bool >>=* _ = Bool - String >>=* _ = String - Arr a b >>=* f = Arr (a >>= f) (b >>= f) - Record m >>=* f = Record ((>>= f) <$> m) + item >>=* go = case item of + Bool -> Bool + Unit -> Unit + String -> String + Arr l r -> Arr (l >>= go) (r >>= go) + Record items -> Record (fmap (>>= go) items) type Meta = Int newtype Polytype f a = PForAll (Scope () f a) - deriving (Foldable, Functor, Generic1, Traversable) + deriving (Foldable, Functor, Generic1, HFunctor, RightModule, Traversable) deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Polytype f a) deriving instance (Ord a, forall a . Eq a => Eq (f a) , forall a . Ord a => Ord (f a), Monad f) => Ord (Polytype f a) deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Polytype f a) -instance HFunctor Polytype -instance RightModule Polytype where - PForAll b >>=* f = PForAll (b >>=* f) - -forAll :: (Eq a, Carrier sig m, Member Polytype sig) => a -> m a -> m a +forAll :: (Eq a, Has Polytype sig m) => a -> m a -> m a forAll n body = send (PForAll (abstract1 n body)) -forAlls :: (Eq a, Carrier sig m, Member Polytype sig, Foldable t) => t a -> m a -> m a +forAlls :: (Eq a, Has Polytype sig m, Foldable t) => t a -> m a -> m a forAlls ns body = foldr forAll body ns generalize :: Term (Monotype name) Meta -> Term (Polytype :+: Monotype name) Void @@ -95,7 +93,7 @@ generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R typecheckingFlowInsensitive :: (Ord name, Ord (term name), Show name) => (forall sig m - . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) + . (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m, MonadFail m) => Analysis term name name (Type name) m -> (term name -> m (Type name)) -> (term name -> m (Type name)) @@ -106,23 +104,22 @@ typecheckingFlowInsensitive ) typecheckingFlowInsensitive eval = run - . runFresh + . evalFresh 0 . runHeap . fmap (fmap (fmap (fmap generalize))) . traverse (runFile eval) runFile :: forall term name m sig - . ( Carrier sig m - , Effect sig - , Member Fresh sig - , Member (State (Heap name (Type name))) sig + . ( Effect sig + , Has Fresh sig m + , Has (State (Heap name (Type name))) sig m , Ord name , Ord (term name) , Show name ) => (forall sig m - . (Carrier sig m, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig, MonadFail m) + . (Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m, MonadFail m) => Analysis term name name (Type name) m -> (term name -> m (Type name)) -> (term name -> m (Type name)) @@ -147,14 +144,13 @@ runFile eval file = traverse run file v <- meta bs <- m v <$ for_ bs (unify v)) - . convergeTerm (Proxy @name) (fix (cacheTerm . eval typecheckingAnalysis)) + . convergeTerm (Proxy @name) 1 (fix (cacheTerm . eval typecheckingAnalysis)) typecheckingAnalysis :: ( Alternative m - , Carrier sig m - , Member Fresh sig - , Member (State (Set.Set (Constraint name))) sig - , Member (State (Heap name (Type name))) sig + , Has Fresh sig m + , Has (State (Set.Set (Constraint name))) sig m + , Has (State (Heap name (Type name))) sig m , Ord name ) => Analysis term name name (Type name) m @@ -202,17 +198,17 @@ data Solution name infix 5 := -meta :: (Carrier sig m, Member Fresh sig) => m (Type name) +meta :: Has Fresh sig m => m (Type name) meta = pure <$> Fresh.fresh -unify :: (Carrier sig m, Member (State (Set.Set (Constraint name))) sig, Ord name) => Type name -> Type name -> m () +unify :: (Has (State (Set.Set (Constraint name))) sig m, Ord name) => Type name -> Type name -> m () unify t1 t2 | t1 == t2 = pure () | otherwise = modify (<> Set.singleton (t1 :===: t2)) type Substitution name = IntMap.IntMap (Type name) -solve :: (Member (State (Substitution name)) sig, MonadFail m, Ord name, Show name, Carrier sig m) => Set.Set (Constraint name) -> m () +solve :: (Has (State (Substitution name)) sig m, MonadFail m, Ord name, Show name) => Set.Set (Constraint name) -> m () solve cs = for_ cs solve where solve = \case -- FIXME: how do we enforce proper subtyping? row polymorphism or something? diff --git a/semantic-analysis/src/Control/Carrier/Fail/WithLoc.hs b/semantic-analysis/src/Control/Carrier/Fail/WithLoc.hs index 90cf3c157..6abce03f4 100644 --- a/semantic-analysis/src/Control/Carrier/Fail/WithLoc.hs +++ b/semantic-analysis/src/Control/Carrier/Fail/WithLoc.hs @@ -8,9 +8,9 @@ module Control.Carrier.Fail.WithLoc ) where import Control.Applicative -import Control.Effect.Carrier -import Control.Effect.Error -import Control.Effect.Fail (Fail(..), MonadFail(..)) +import Control.Algebra +import Control.Carrier.Error.Either +import Control.Effect.Fail import Control.Effect.Reader import Prelude hiding (fail) import Source.Span @@ -22,12 +22,12 @@ runFail = runError . runFailC newtype FailC m a = FailC { runFailC :: ErrorC (Path.AbsRelFile, Span, String) m a } deriving (Alternative, Applicative, Functor, Monad) -instance (Carrier sig m, Effect sig, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig) => MonadFail (FailC m) where +instance (Effect sig, Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m) => MonadFail (FailC m) where fail s = do path <- ask span <- ask FailC (throwError (path :: Path.AbsRelFile, span :: Span, s)) -instance (Carrier sig m, Effect sig, Member (Reader Path.AbsRelFile) sig, Member (Reader Span) sig) => Carrier (Fail :+: sig) (FailC m) where - eff (L (Fail s)) = fail s - eff (R other) = FailC (eff (R (handleCoercible other))) +instance (Effect sig, Has (Reader Path.AbsRelFile) sig m, Has (Reader Span) sig m) => Algebra (Fail :+: sig) (FailC m) where + alg (L (Fail s)) = fail s + alg (R other) = FailC (alg (R (handleCoercible other))) diff --git a/semantic-analysis/src/Control/Carrier/Readline/Haskeline.hs b/semantic-analysis/src/Control/Carrier/Readline/Haskeline.hs index b7222acfb..6c43d1bb1 100644 --- a/semantic-analysis/src/Control/Carrier/Readline/Haskeline.hs +++ b/semantic-analysis/src/Control/Carrier/Readline/Haskeline.hs @@ -1,21 +1,18 @@ {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeOperators, UndecidableInstances #-} module Control.Carrier.Readline.Haskeline -( -- * Readline effect - module Control.Effect.Readline - -- * Readline carrier -, runReadline +( -- * Readline carrier + runReadline , runReadlineWithHistory , ReadlineC (..) - -- * Re-exports -, Carrier -, run + -- * Readline effect +, module Control.Effect.Readline , runM ) where -import Control.Effect.Carrier -import Control.Effect.Lift -import Control.Effect.Reader -import Control.Effect.Readline hiding (Carrier) +import Control.Algebra +import Control.Carrier.Lift +import Control.Carrier.Reader +import Control.Effect.Readline import Control.Monad.Fix import Control.Monad.IO.Class import Data.Coerce @@ -48,14 +45,14 @@ runReadlineWithHistory block = do newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (LiftC (InputT m)) a } deriving (Applicative, Functor, Monad, MonadFix, MonadIO) -instance MonadException m => Carrier Readline (ReadlineC m) where - eff (Prompt prompt k) = ReadlineC $ do +instance MonadException m => Algebra Readline (ReadlineC m) where + alg (Prompt prompt k) = ReadlineC $ do str <- sendM (getInputLine @m (cyan <> prompt <> plain)) Line line <- ask local increment (runReadlineC (k line str)) where cyan = "\ESC[1;36m\STX" plain = "\ESC[0m\STX" - eff (Print doc k) = do + alg (Print doc k) = do s <- maybe 80 Size.width <$> liftIO size liftIO (renderIO stdout (layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine s 0.8 } (doc <> line))) k diff --git a/semantic-analysis/src/Control/Effect/Readline.hs b/semantic-analysis/src/Control/Effect/Readline.hs index 1a4b31639..ad41dd968 100644 --- a/semantic-analysis/src/Control/Effect/Readline.hs +++ b/semantic-analysis/src/Control/Effect/Readline.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, MultiParamTypeClasses #-} module Control.Effect.Readline ( -- * Readline effect Readline (..) , prompt , print -- * Re-exports -, Carrier +, Algebra +, Has +, run ) where -import Control.Effect.Carrier +import Control.Algebra import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal import GHC.Generics (Generic1) @@ -20,11 +22,11 @@ data Readline m k deriving (Functor, Generic1) instance HFunctor Readline -instance Effect Readline +instance Effect Readline -prompt :: (Member Readline sig, Carrier sig m) => String -> m (Int, Maybe String) +prompt :: Has Readline sig m => String -> m (Int, Maybe String) prompt p = send (Prompt p (curry pure)) -print :: (Carrier sig m, Member Readline sig) => Doc AnsiStyle -> m () +print :: Has Readline sig m => Doc AnsiStyle -> m () print s = send (Print s (pure ())) diff --git a/semantic-ast/semantic-ast.cabal b/semantic-ast/semantic-ast.cabal index d5d6ea86e..84e40ffb9 100644 --- a/semantic-ast/semantic-ast.cabal +++ b/semantic-ast/semantic-ast.cabal @@ -41,7 +41,7 @@ library -- other-modules: -- other-extensions: build-depends: base ^>=4.12.0.0 - , tree-sitter ^>= 0.7 + , tree-sitter ^>= 0.7.1 , semantic-source ^>= 0.0 , tree-sitter-python ^>= 0.8 , bytestring ^>= 0.10.8.2 diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal index 0be3f8a50..be48eb0e8 100644 --- a/semantic-core/semantic-core.cabal +++ b/semantic-core/semantic-core.cabal @@ -47,7 +47,7 @@ library Core.Name build-depends: base >= 4.12 && < 5 - , fused-effects ^>= 0.5 + , fused-effects ^>= 1.0 , fused-syntax , parsers ^>= 0.12.10 , pathtype ^>= 0.8.1 diff --git a/semantic-core/src/Core/Core.hs b/semantic-core/src/Core/Core.hs index 9fa8d62b6..4d12cecc4 100644 --- a/semantic-core/src/Core/Core.hs +++ b/semantic-core/src/Core/Core.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, LambdaCase, MultiParamTypeClasses, OverloadedStrings, - QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, - UndecidableInstances #-} +{-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleContexts, LambdaCase, MultiParamTypeClasses, OverloadedStrings, QuantifiedConstraints, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Core.Core ( Core(..) , rec @@ -37,8 +35,8 @@ module Core.Core , stripAnnotations ) where +import Control.Algebra import Control.Applicative (Alternative (..)) -import Control.Effect.Carrier import Core.Name import Data.Bifunctor (Bifunctor (..)) import Data.Foldable (foldl') @@ -52,6 +50,7 @@ import Syntax.Foldable import Syntax.Module import Syntax.Scope import Syntax.Stack +import Syntax.Sum import Syntax.Term import Syntax.Traversable @@ -95,11 +94,6 @@ instance HFunctor Core instance HFoldable Core instance HTraversable Core -deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Core f a) -deriving instance (Ord a, forall a . Eq a => Eq (f a) - , forall a . Ord a => Ord (f a), Monad f) => Ord (Core f a) -deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Core f a) - instance RightModule Core where Rec b >>=* f = Rec ((>>=* f) <$> b) (a :>> b) >>=* f = (a >>= f) :>> (b >>= f) @@ -116,20 +110,25 @@ instance RightModule Core where (a :? b) >>=* f = (a >>= f) :. b (a := b) >>=* f = (a >>= f) := (b >>= f) +deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Core f a) +deriving instance (Ord a, forall a . Eq a => Eq (f a) + , forall a . Ord a => Ord (f a), Monad f) => Ord (Core f a) +deriving instance (Show a, forall a . Show a => Show (f a)) => Show (Core f a) -rec :: (Eq a, Carrier sig m, Member Core sig) => Named a -> m a -> m a + +rec :: (Eq a, Has Core sig m) => Named a -> m a -> m a rec (Named u n) b = send (Rec (Named u (abstract1 n b))) -(>>>) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a +(>>>) :: Has Core sig m => m a -> m a -> m a a >>> b = send (a :>> b) infixr 1 >>> -unseq :: (Alternative m, Member Core sig) => Term sig a -> m (Term sig a, Term sig a) +unseq :: (Alternative m, Project Core sig) => Term sig a -> m (Term sig a, Term sig a) unseq (Alg sig) | Just (a :>> b) <- prj sig = pure (a, b) unseq _ = empty -unseqs :: Member Core sig => Term sig a -> NonEmpty (Term sig a) +unseqs :: Project Core sig => Term sig a -> NonEmpty (Term sig a) unseqs = go where go t = case unseq t of Just (l, r) -> go l <> go r @@ -137,23 +136,23 @@ unseqs = go -- TODO: if the left hand side is only a unit, this should return just the RHS -- this is a little fiddly to do -(>>>=) :: (Eq a, Carrier sig m, Member Core sig) => (Named a :<- m a) -> m a -> m a +(>>>=) :: (Eq a, Has Core sig m) => (Named a :<- m a) -> m a -> m a Named u n :<- a >>>= b = send (Named u a :>>= abstract1 n b) infixr 1 >>>= -unbind :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (Named a :<- Term sig a, Term sig a) +unbind :: (Alternative m, Project Core sig, RightModule sig) => a -> Term sig a -> m (Named a :<- Term sig a, Term sig a) unbind n (Alg sig) | Just (Named u a :>>= b) <- prj sig = pure (Named u n :<- a, instantiate1 (pure n) b) unbind _ _ = empty -unstatement :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (Maybe (Named a) :<- Term sig a, Term sig a) +unstatement :: (Alternative m, Project Core sig, RightModule sig) => a -> Term sig a -> m (Maybe (Named a) :<- Term sig a, Term sig a) unstatement n t = first (first Just) <$> unbind n t <|> first (Nothing :<-) <$> unseq t -do' :: (Eq a, Foldable t, Carrier sig m, Member Core sig) => t (Maybe (Named a) :<- m a) -> m a +do' :: (Eq a, Foldable t, Has Core sig m) => t (Maybe (Named a) :<- m a) -> m a do' bindings = fromMaybe unit (foldr bind Nothing bindings) where bind (n :<- a) v = maybe (a >>>) ((>>>=) . (:<- a)) n <$> v <|> Just a -unstatements :: (Member Core sig, RightModule sig) => Term sig a -> (Stack (Maybe (Named (Either Int a)) :<- Term sig (Either Int a)), Term sig (Either Int a)) +unstatements :: (Project Core sig, RightModule sig) => Term sig a -> (Stack (Maybe (Named (Either Int a)) :<- Term sig (Either Int a)), Term sig (Either Int a)) unstatements = unprefix (unstatement . Left) . fmap Right data a :<- b = a :<- b @@ -165,65 +164,65 @@ instance Bifunctor (:<-) where bimap f g (a :<- b) = f a :<- g b -lam :: (Eq a, Carrier sig m, Member Core sig) => Named a -> m a -> m a +lam :: (Eq a, Has Core sig m) => Named a -> m a -> m a lam (Named u n) b = send (Lam (Named u (abstract1 n b))) -lams :: (Eq a, Foldable t, Carrier sig m, Member Core sig) => t (Named a) -> m a -> m a +lams :: (Eq a, Foldable t, Has Core sig m) => t (Named a) -> m a -> m a lams names body = foldr lam body names -unlam :: (Alternative m, Member Core sig, RightModule sig) => a -> Term sig a -> m (Named a, Term sig a) +unlam :: (Alternative m, Project Core sig, RightModule sig) => a -> Term sig a -> m (Named a, Term sig a) unlam n (Alg sig) | Just (Lam b) <- prj sig = pure (n <$ b, instantiate1 (pure n) (namedValue b)) unlam _ _ = empty -($$) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a +($$) :: Has Core sig m => m a -> m a -> m a f $$ a = send (f :$ a) infixl 8 $$ -- | Application of a function to a sequence of arguments. -($$*) :: (Foldable t, Carrier sig m, Member Core sig) => m a -> t (m a) -> m a +($$*) :: (Foldable t, Has Core sig m) => m a -> t (m a) -> m a ($$*) = foldl' ($$) infixl 8 $$* -unapply :: (Alternative m, Member Core sig) => Term sig a -> m (Term sig a, Term sig a) +unapply :: (Alternative m, Project Core sig) => Term sig a -> m (Term sig a, Term sig a) unapply (Alg sig) | Just (f :$ a) <- prj sig = pure (f, a) unapply _ = empty -unapplies :: Member Core sig => Term sig a -> (Term sig a, Stack (Term sig a)) +unapplies :: Project Core sig => Term sig a -> (Term sig a, Stack (Term sig a)) unapplies core = case unapply core of Just (f, a) -> (:> a) <$> unapplies f Nothing -> (core, Nil) -unit :: (Carrier sig m, Member Core sig) => m a +unit :: Has Core sig m => m a unit = send Unit -bool :: (Carrier sig m, Member Core sig) => Bool -> m a +bool :: Has Core sig m => Bool -> m a bool = send . Bool -if' :: (Carrier sig m, Member Core sig) => m a -> m a -> m a -> m a +if' :: Has Core sig m => m a -> m a -> m a -> m a if' c t e = send (If c t e) -string :: (Carrier sig m, Member Core sig) => Text -> m a +string :: Has Core sig m => Text -> m a string = send . String -load :: (Carrier sig m, Member Core sig) => m a -> m a +load :: Has Core sig m => m a -> m a load = send . Load -record :: (Carrier sig m, Member Core sig) => [(Name, m a)] -> m a +record :: Has Core sig m => [(Name, m a)] -> m a record fs = send (Record fs) -(...) :: (Carrier sig m, Member Core sig) => m a -> Name -> m a +(...) :: Has Core sig m => m a -> Name -> m a a ... b = send (a :. b) infixl 9 ... -(.?) :: (Carrier sig m, Member Core sig) => m a -> Name -> m a +(.?) :: Has Core sig m => m a -> Name -> m a a .? b = send (a :? b) infixl 9 .? -(.=) :: (Carrier sig m, Member Core sig) => m a -> m a -> m a +(.=) :: Has Core sig m => m a -> m a -> m a a .= b = send (a := b) infix 3 .= @@ -241,17 +240,17 @@ instance RightModule (Ann ann) where Ann l b >>=* f = Ann l (b >>= f) -ann :: (Carrier sig m, Member (Ann Span) sig) => HasCallStack => m a -> m a +ann :: Has (Ann Span) sig m => HasCallStack => m a -> m a ann = annWith callStack -annAt :: (Carrier sig m, Member (Ann ann) sig) => ann -> m a -> m a +annAt :: Has (Ann ann) sig m => ann -> m a -> m a annAt ann = send . Ann ann -annWith :: (Carrier sig m, Member (Ann Span) sig) => CallStack -> m a -> m a +annWith :: Has (Ann Span) sig m => CallStack -> m a -> m a annWith callStack = maybe id (annAt . spanFromSrcLoc . snd) (listToMaybe (getCallStack callStack)) -stripAnnotations :: forall ann a sig . (HFunctor sig, forall g . Functor g => Functor (sig g)) => Term (Ann ann :+: sig) a -> Term sig a +stripAnnotations :: forall ann a sig . RightModule sig => Term (Ann ann :+: sig) a -> Term sig a stripAnnotations (Var v) = Var v stripAnnotations (Alg (L (Ann _ b))) = stripAnnotations b stripAnnotations (Alg (R b)) = Alg (hmap stripAnnotations b) diff --git a/semantic-core/src/Core/Eval.hs b/semantic-core/src/Core/Eval.hs index f7c23b5d7..ba9c47360 100644 --- a/semantic-core/src/Core/Eval.hs +++ b/semantic-core/src/Core/Eval.hs @@ -12,8 +12,8 @@ module Core.Eval import Analysis.Analysis import Analysis.File +import Control.Algebra import Control.Applicative (Alternative (..)) -import Control.Effect.Carrier import Control.Effect.Fail import Control.Effect.Reader import Control.Monad ((>=>)) @@ -28,8 +28,7 @@ import Syntax.Scope import Syntax.Term import qualified System.Path as Path -eval :: ( Carrier sig m - , Member (Reader Span) sig +eval :: ( Has (Reader Span) sig m , MonadFail m , Semigroup value ) @@ -98,30 +97,30 @@ eval Analysis{..} eval = \case Alg (L (Ann span c)) -> local (const span) (ref c) -prog1 :: (Carrier sig t, Member Core sig) => File (t Name) +prog1 :: Has Core sig t => File (t Name) prog1 = fromBody $ lam (named' "foo") ( named' "bar" :<- pure "foo" >>>= Core.if' (pure "bar") (Core.bool False) (Core.bool True)) -prog2 :: (Carrier sig t, Member Core sig) => File (t Name) +prog2 :: Has Core sig t => File (t Name) prog2 = fromBody $ fileBody prog1 $$ Core.bool True -prog3 :: (Carrier sig t, Member Core sig) => File (t Name) +prog3 :: Has Core sig t => File (t Name) prog3 = fromBody $ lams [named' "foo", named' "bar", named' "quux"] (Core.if' (pure "quux") (pure "bar") (pure "foo")) -prog4 :: (Carrier sig t, Member Core sig) => File (t Name) +prog4 :: Has Core sig t => File (t Name) prog4 = fromBody ( named' "foo" :<- Core.bool True >>>= Core.if' (pure "foo") (Core.bool True) (Core.bool False)) -prog5 :: (Carrier sig t, Member (Ann Span) sig, Member Core sig) => File (t Name) +prog5 :: (Has (Ann Span) sig t, Has Core sig t) => File (t Name) prog5 = fromBody $ ann (do' [ Just (named' "mkPoint") :<- lams [named' "_x", named' "_y"] (ann (Core.record [ ("x", ann (pure "_x")) @@ -132,7 +131,7 @@ prog5 = fromBody $ ann (do' , Nothing :<- ann (ann (pure "point") Core.... "y") .= ann (ann (pure "point") Core.... "x") ]) -prog6 :: (Carrier sig t, Member Core sig) => [File (t Name)] +prog6 :: Has Core sig t => [File (t Name)] prog6 = [ (fromBody (Core.record [ ("dep", Core.record [ ("var", Core.bool True) ]) ])) @@ -144,7 +143,7 @@ prog6 = { filePath = Path.absRel "main" } ] -ruby :: (Carrier sig t, Member (Ann Span) sig, Member Core sig) => File (t Name) +ruby :: (Has (Ann Span) sig t, Has Core sig t) => File (t Name) ruby = fromBody $ annWith callStack (rec (named' __semantic_global) (do' statements)) where statements = [ Just "Class" :<- record diff --git a/semantic-core/src/Core/Parser.hs b/semantic-core/src/Core/Parser.hs index 412dab5de..1f49646f6 100644 --- a/semantic-core/src/Core/Parser.hs +++ b/semantic-core/src/Core/Parser.hs @@ -9,8 +9,8 @@ module Core.Parser -- Consult @doc/grammar.md@ for an EBNF grammar. +import Control.Algebra import Control.Applicative -import Control.Effect.Carrier import Control.Monad import Core.Core ((:<-) (..), Core) import qualified Core.Core as Core @@ -57,25 +57,25 @@ identifier = choice [quote, plain] "identifier" where -- * Parsers (corresponding to EBNF) -core :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +core :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) core = runCoreParser expr -expr :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +expr :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) expr = ifthenelse <|> lambda <|> rec <|> load <|> assign -assign :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +assign :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) assign = application <**> (symbolic '=' *> rhs <|> pure id) "assignment" where rhs = flip (Core..=) <$> application -application :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +application :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) application = projection `chainl1` (pure (Core.$$)) -projection :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +projection :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) projection = foldl' (&) <$> atom <*> many (choice [ flip (Core..?) <$ symbol ".?" <*> identifier , flip (Core....) <$ dot <*> identifier ]) -atom :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +atom :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) atom = choice [ comp , lit @@ -83,26 +83,26 @@ atom = choice , parens expr ] -comp :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +comp :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) comp = braces (Core.do' <$> sepEndByNonEmpty statement semi) "compound statement" -statement :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (Maybe (Named Name) :<- t Name) +statement :: (TokenParsing m, Has Core sig t, Monad m) => m (Maybe (Named Name) :<- t Name) statement = try ((:<-) . Just <$> name <* symbol "<-" <*> expr) <|> (Nothing :<-) <$> expr "statement" -ifthenelse :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +ifthenelse :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) ifthenelse = Core.if' <$ reserved "if" <*> expr <* reserved "then" <*> expr <* reserved "else" <*> expr "if-then-else statement" -rec :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +rec :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) rec = Core.rec <$ reserved "rec" <*> name <* symbolic '=' <*> expr "recursive binding" -load :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +load :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) load = Core.load <$ reserved "load" <*> expr -- * Literals @@ -110,7 +110,7 @@ load = Core.load <$ reserved "load" <*> expr name :: (TokenParsing m, Monad m) => m (Named Name) name = named' <$> identifier "name" -lit :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +lit :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) lit = let x `given` n = x <$ reserved n in choice [ Core.bool True `given` "#true" , Core.bool False `given` "#false" @@ -119,10 +119,10 @@ lit = let x `given` n = x <$ reserved n in choice , Core.string <$> stringLiteral ] "literal" -record :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +record :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) record = Core.record <$ reserved "#record" <*> braces (sepEndBy ((,) <$> identifier <* symbolic ':' <*> expr) comma) -lambda :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t Name) +lambda :: (TokenParsing m, Has Core sig t, Monad m) => m (t Name) lambda = Core.lam <$ lambduh <*> name <* arrow <*> expr "lambda" where lambduh = symbolic 'λ' <|> symbolic '\\' arrow = symbol "→" <|> symbol "->" diff --git a/semantic-core/test/Generators.hs b/semantic-core/test/Generators.hs index d96a82cdf..ee56f1d4b 100644 --- a/semantic-core/test/Generators.hs +++ b/semantic-core/test/Generators.hs @@ -12,13 +12,13 @@ module Generators , expr ) where -import Hedgehog hiding (Var) +import Hedgehog hiding (Var) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Control.Effect.Carrier +import Control.Algebra import qualified Core.Core as Core -import Core.Name +import Core.Name -- The 'prune' call here ensures that we don't spend all our time just generating -- fresh names for variables, since the length of variable names is not an @@ -27,16 +27,16 @@ name :: MonadGen m => m (Named Name) name = Gen.prune (named' <$> names) where names = Name <$> Gen.text (Range.linear 1 10) Gen.lower -boolean :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) +boolean :: (Has Core.Core sig t, MonadGen m) => m (t Name) boolean = Core.bool <$> Gen.bool variable :: (Applicative t, MonadGen m) => m (t Name) variable = pure . namedValue <$> name -ifthenelse :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) -> m (t Name) +ifthenelse :: (Has Core.Core sig t, MonadGen m) => m (t Name) -> m (t Name) ifthenelse bod = Gen.subterm3 boolean bod bod Core.if' -apply :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) -> m (t Name) +apply :: (Has Core.Core sig t, MonadGen m) => m (t Name) -> m (t Name) apply gen = go where go = Gen.recursive Gen.choice @@ -45,21 +45,21 @@ apply gen = go where , Gen.subtermM go (\x -> Core.lam <$> name <*> pure x) ] -lambda :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) -> m (t Name) +lambda :: (Has Core.Core sig t, MonadGen m) => m (t Name) -> m (t Name) lambda bod = do arg <- name Gen.subterm bod (Core.lam arg) -record :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) -> m (t Name) +record :: (Has Core.Core sig t, MonadGen m) => m (t Name) -> m (t Name) record bod = Core.record <$> Gen.list (Range.linear 0 5) ((,) . namedValue <$> name <*> bod) -atoms :: (Carrier sig t, Member Core.Core sig, MonadGen m) => [m (t Name)] +atoms :: (Has Core.Core sig t, MonadGen m) => [m (t Name)] atoms = [variable, pure Core.unit, boolean, Core.string <$> Gen.text (Range.linear 1 10) Gen.lower] -literal :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) +literal :: (Has Core.Core sig t, MonadGen m) => m (t Name) literal = Gen.recursive Gen.choice atoms [lambda literal, record literal] -expr :: (Carrier sig t, Member Core.Core sig, MonadGen m) => m (t Name) +expr :: (Has Core.Core sig t, MonadGen m) => m (t Name) expr = Gen.recursive Gen.choice atoms [ Gen.subtermM expr (\x -> flip Core.rec x <$> name) , Gen.subterm2 expr expr (Core.>>>) diff --git a/semantic-java/semantic-java.cabal b/semantic-java/semantic-java.cabal index 7125e1975..5b9704447 100644 --- a/semantic-java/semantic-java.cabal +++ b/semantic-java/semantic-java.cabal @@ -24,10 +24,10 @@ library Language.Java.Tags build-depends: base >= 4.12 && < 5 - , fused-effects ^>= 0.5 + , fused-effects ^>= 1.0 , semantic-source ^>= 0.0 , semantic-tags ^>= 0.0 - , tree-sitter ^>= 0.7 + , tree-sitter ^>= 0.7.1 , tree-sitter-java ^>= 0.6 hs-source-dirs: src default-language: Haskell2010 diff --git a/semantic-java/src/Language/Java/Tags.hs b/semantic-java/src/Language/Java/Tags.hs index 101def1a5..6267e2ddb 100644 --- a/semantic-java/src/Language/Java/Tags.hs +++ b/semantic-java/src/Language/Java/Tags.hs @@ -16,9 +16,8 @@ import qualified TreeSitter.Java.AST as Java class ToTags t where tags - :: ( Carrier sig m - , Member (Reader Source) sig - , Member (Writer Tags.Tags) sig + :: ( Has (Reader Source) sig m + , Has (Writer Tags.Tags) sig m ) => t Loc -> m () @@ -29,9 +28,8 @@ instance (ToTagsBy strategy t, strategy ~ ToTagsInstance t) => ToTags t where class ToTagsBy (strategy :: Strategy) t where tags' - :: ( Carrier sig m - , Member (Reader Source) sig - , Member (Writer Tags.Tags) sig + :: ( Has (Reader Source) sig m + , Has (Writer Tags.Tags) sig m ) => t Loc -> m () @@ -89,9 +87,8 @@ instance ToTagsBy 'Custom Java.MethodInvocation where gtags - :: ( Carrier sig m - , Member (Reader Source) sig - , Member (Writer Tags.Tags) sig + :: ( Has (Reader Source) sig m + , Has (Writer Tags.Tags) sig m , Generic1 t , Tags.GFoldable1 ToTags (Rep1 t) ) diff --git a/semantic-python/semantic-python.cabal b/semantic-python/semantic-python.cabal index c4eacdb23..8d7472f1b 100644 --- a/semantic-python/semantic-python.cabal +++ b/semantic-python/semantic-python.cabal @@ -21,7 +21,7 @@ tested-with: GHC == 8.6.5 common haskell default-language: Haskell2010 build-depends: base ^>=4.12 - , fused-effects ^>= 0.5 + , fused-effects ^>= 1.0 , fused-syntax , parsers ^>= 0.12.10 , semantic-core ^>= 0.0 diff --git a/semantic-python/src/Language/Python/Core.hs b/semantic-python/src/Language/Python/Core.hs index 06466e71e..3bf100958 100644 --- a/semantic-python/src/Language/Python/Core.hs +++ b/semantic-python/src/Language/Python/Core.hs @@ -10,7 +10,7 @@ module Language.Python.Core import Prelude hiding (fail) import AST.Element -import Control.Effect hiding ((:+:)) +import Control.Algebra hiding ((:+:)) import Control.Effect.Reader import Core.Core as Core import Core.Name as Name @@ -49,28 +49,25 @@ pattern SingleIdentifier name <- Py.ExpressionList -- We leave the representation of Core syntax abstract so that it's not -- possible for us to 'cheat' by pattern-matching on or eliminating a -- compiled term. -type CoreSyntax sig t = ( Member Core sig - , Member (Ann Span) sig - , Member Failure sig - , Carrier sig t +type CoreSyntax sig t = ( Has Core sig t + , Has (Ann Span) sig t + , Has Failure sig t , Foldable t ) class Compile (py :: * -> *) where compile :: ( CoreSyntax syn t - , Member (Reader Bindings) sig - , Carrier sig m + , Has (Reader Bindings) sig m ) => py Span -> (t Name -> m (t Name)) -> (t Name -> m (t Name)) - default compile :: (Applicative m, Member Failure syn, Carrier syn t, Show (py Span)) => py Span -> (t Name -> m (t Name)) -> (t Name -> m (t Name)) + default compile :: (Applicative m, Has Failure syn t, Show (py Span)) => py Span -> (t Name -> m (t Name)) -> (t Name -> m (t Name)) compile a _ _ = defaultCompile a toplevelCompile :: ( CoreSyntax syn t - , Member (Reader Bindings) sig - , Carrier sig m + , Has (Reader Bindings) sig m ) => Py.Module Span -> m (t Name) @@ -78,7 +75,7 @@ toplevelCompile py = compile py pure none -- | TODO: This is not right, it should be a reference to a Preluded -- NoneType instance, but it will do for now. -none :: (Member Core sig, Carrier sig t) => t Name +none :: Has Core sig t => t Name none = unit locate :: ( HasField "ann" syntax Span @@ -89,7 +86,7 @@ locate :: ( HasField "ann" syntax Span -> t a locate syn = Core.annAt (getField @"ann" syn) -defaultCompile :: (Applicative m, Member Failure syn, Carrier syn t, Show py) => py -> m (t Name) +defaultCompile :: (Applicative m, Has Failure syn t, Show py) => py -> m (t Name) defaultCompile = pure . unimplemented @@ -142,7 +139,7 @@ desugar acc = \case -- returns a function). There's some pun to be made on "collapsing -- sugar", like "icing" or "sugar water" but I'll leave that as an -- exercise to the reader. -collapseDesugared :: (CoreSyntax syn t, Member (Reader Bindings) sig, Carrier sig m) +collapseDesugared :: (CoreSyntax syn t, Has (Reader Bindings) sig m) => Located Name -- The current LHS to which to assign -> (t Name -> m (t Name)) -- A meta-continuation: it takes a name and returns a continuation -> t Name -- The current RHS to which to assign, yielded from an outer continuation diff --git a/semantic-python/src/Language/Python/Failure.hs b/semantic-python/src/Language/Python/Failure.hs index e9943d9b9..8f499b286 100644 --- a/semantic-python/src/Language/Python/Failure.hs +++ b/semantic-python/src/Language/Python/Failure.hs @@ -11,7 +11,7 @@ module Language.Python.Failure import Prelude hiding (fail) -import Control.Effect.Carrier +import Control.Algebra import Control.Monad.Fail import Data.Coerce import Data.Kind @@ -42,10 +42,10 @@ instance RightModule Failure where a >>=* _ = coerce a -unimplemented :: (Show ast, Member Failure sig, Carrier sig m) => ast -> m a +unimplemented :: (Show ast, Has Failure sig m) => ast -> m a unimplemented = send . Unimplemented . show -invariantViolated :: (Member Failure sig, Carrier sig m) => String -> m a +invariantViolated :: Has Failure sig m => String -> m a invariantViolated = send . InvariantViolated eliminateFailures :: (MonadFail m, HTraversable sig, RightModule sig) diff --git a/semantic-python/src/Language/Python/Tags.hs b/semantic-python/src/Language/Python/Tags.hs index 5fd9af258..57d79c825 100644 --- a/semantic-python/src/Language/Python/Tags.hs +++ b/semantic-python/src/Language/Python/Tags.hs @@ -20,9 +20,8 @@ import qualified TreeSitter.Python.AST as Py class ToTags t where tags - :: ( Carrier sig m - , Member (Reader Source) sig - , Member (Writer Tags.Tags) sig + :: ( Has (Reader Source) sig m + , Has (Writer Tags.Tags) sig m ) => t Loc -> m () @@ -33,9 +32,8 @@ instance (ToTagsBy strategy t, strategy ~ ToTagsInstance t) => ToTags t where class ToTagsBy (strategy :: Strategy) t where tags' - :: ( Carrier sig m - , Member (Reader Source) sig - , Member (Writer Tags.Tags) sig + :: ( Has (Reader Source) sig m + , Has (Writer Tags.Tags) sig m ) => t Loc -> m () @@ -96,9 +94,8 @@ docComment _ _ = Nothing gtags - :: ( Carrier sig m - , Member (Reader Source) sig - , Member (Writer Tags.Tags) sig + :: ( Has (Reader Source) sig m + , Has (Writer Tags.Tags) sig m , Generic1 t , Tags.GFoldable1 ToTags (Rep1 t) ) diff --git a/semantic-python/test/Directive.hs b/semantic-python/test/Directive.hs index 32c3ef9c4..83634e235 100644 --- a/semantic-python/test/Directive.hs +++ b/semantic-python/test/Directive.hs @@ -8,8 +8,8 @@ module Directive ( Directive (..) ) where import Analysis.Concrete (Concrete (..)) +import Control.Algebra import Control.Applicative -import Control.Effect import Control.Monad import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Core.Core (Core) diff --git a/semantic-python/test/Test.hs b/semantic-python/test/Test.hs index f5935ed01..2931598d4 100644 --- a/semantic-python/test/Test.hs +++ b/semantic-python/test/Test.hs @@ -6,9 +6,9 @@ import Analysis.Concrete (Concrete) import qualified Analysis.Concrete as Concrete import Analysis.File import Analysis.ScopeGraph -import Control.Effect -import Control.Effect.Fail -import Control.Effect.Reader +import Control.Algebra +import Control.Carrier.Fail.Either +import Control.Carrier.Reader import Control.Monad hiding (fail) import Control.Monad.Catch import Control.Monad.IO.Class @@ -118,10 +118,10 @@ checkPythonFile fp = HUnit.testCaseSteps (Path.toString fp) $ \step -> withFroze result <- ByteString.readFile (Path.toString fullPath) >>= TS.parseByteString TSP.tree_sitter_python -- Run the compiler - let coreResult = Control.Effect.run + let coreResult = Control.Algebra.run . runFail . eliminateFailures - . Control.Effect.run + . Control.Algebra.run . runReader @Py.Bindings mempty . Py.toplevelCompile @(Failure :+: Ann Span :+: Core) @(Term _) <$> result diff --git a/semantic-tags/semantic-tags.cabal b/semantic-tags/semantic-tags.cabal index 9d16c0d3b..e3c9e05fa 100644 --- a/semantic-tags/semantic-tags.cabal +++ b/semantic-tags/semantic-tags.cabal @@ -25,7 +25,7 @@ library Tags.Tagging.Precise build-depends: base >= 4.12 && < 5 - , fused-effects ^>= 0.5 + , fused-effects ^>= 1.0 , semantic-source ^>= 0.0 , text ^>= 1.2.3.1 hs-source-dirs: src diff --git a/semantic-tags/src/Tags/Tagging/Precise.hs b/semantic-tags/src/Tags/Tagging/Precise.hs index 6f8c510bb..2cf73a6e9 100644 --- a/semantic-tags/src/Tags/Tagging/Precise.hs +++ b/semantic-tags/src/Tags/Tagging/Precise.hs @@ -8,9 +8,9 @@ module Tags.Tagging.Precise , GFoldable1(..) ) where -import Control.Effect.Pure -import Control.Effect.Reader -import Control.Effect.Writer +import Control.Carrier.Reader +import Control.Carrier.Writer.Strict +import Data.Functor.Identity import Data.Monoid (Endo(..)) import Data.Text as Text (Text, takeWhile) import GHC.Generics @@ -26,12 +26,12 @@ class ToTags t where tags :: Source -> t Loc -> [Tag] -yield :: (Carrier sig m, Member (Writer Tags) sig) => Tag -> m () +yield :: Has (Writer Tags) sig m => Tag -> m () yield = tell . Endo . (:) . modSpan toOneIndexed where modSpan f t@Tag{ loc = l } = t { loc = l { span = f (span l) } } toOneIndexed (Span (Pos l1 c1) (Pos l2 c2)) = Span (Pos (l1 + 1) (c1 + 1)) (Pos (l2 + 1) (c2 + 1)) -runTagging :: Source -> ReaderC Source (WriterC Tags PureC) () -> [Tag] +runTagging :: Source -> ReaderC Source (WriterC Tags Identity) () -> [Tag] runTagging source = ($ []) . appEndo diff --git a/semantic.cabal b/semantic.cabal index d002bd7b7..fe82182ac 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -55,10 +55,11 @@ common dependencies , containers ^>= 0.6.0.1 , directory ^>= 1.3.3.0 , fastsum ^>= 0.1.1.0 - , fused-effects ^>= 0.5.0.0 - , fused-effects-exceptions ^>= 0.2.0.0 + , fused-effects ^>= 1 + , fused-effects-exceptions ^>= 1 + , fused-effects-resumable ^>= 0.1 , hashable ^>= 1.2.7.0 - , tree-sitter ^>= 0.7 + , tree-sitter ^>= 0.7.1 , mtl ^>= 2.2.2 , network ^>= 2.8.0.0 , pathtype ^>= 0.8.1 @@ -115,6 +116,7 @@ library , Control.Effect.Interpose , Control.Effect.Parse , Control.Effect.REPL + , Control.Effect.Sum.Project -- Datatypes for abstract interpretation , Data.Abstract.Address.Hole , Data.Abstract.Address.Monovariant diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index b54500ca1..b3119db29 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -5,19 +5,26 @@ module Analysis.Abstract.Caching.FlowInsensitive , caching ) where +import Prologue + +import Control.Algebra (Effect) +import Control.Carrier.Fresh.Strict +import Control.Carrier.NonDet.Church +import Control.Carrier.Reader +import Control.Carrier.State.Strict + import Control.Abstract import Data.Abstract.Module import Data.Map.Monoidal as Monoidal hiding (empty) -import Prologue -- | Look up the set of values for a given configuration in the in-cache. -consultOracle :: (Member (Reader (Cache term address value)) sig, Carrier sig m, Ord address, Ord term, Ord value) +consultOracle :: (Has (Reader (Cache term address value)) sig m, Ord address, Ord term, Ord value) => Configuration term address -> Evaluator term address value m (Set value) consultOracle configuration = asks (fromMaybe mempty . cacheLookup configuration) -- | Run an action with the given in-cache. -withOracle :: (Member (Reader (Cache term address value)) sig, Carrier sig m) +withOracle :: Has (Reader (Cache term address value)) sig m => Cache term address value -> Evaluator term address value m a -> Evaluator term address value m a @@ -25,13 +32,13 @@ withOracle cache = local (const cache) -- | Look up the set of values for a given configuration in the out-cache. -lookupCache :: (Member (State (Cache term address value)) sig, Carrier sig m, Ord address, Ord term) +lookupCache :: (Has (State (Cache term address value)) sig m, Ord address, Ord term) => Configuration term address -> Evaluator term address value m (Maybe (Set value)) lookupCache configuration = cacheLookup configuration <$> get -- | Run an action, caching its result and 'Heap' under the given configuration. -cachingConfiguration :: (Member (State (Cache term address value)) sig, Carrier sig m, Ord address, Ord term, Ord value) +cachingConfiguration :: (Has (State (Cache term address value)) sig m, Ord address, Ord term, Ord value) => Configuration term address -> Set value -> Evaluator term address value m value @@ -41,23 +48,22 @@ cachingConfiguration configuration values action = do result <- action result <$ modify (cacheInsert configuration result) -putCache :: (Member (State (Cache term address value)) sig, Carrier sig m) +putCache :: Has (State (Cache term address value)) sig m => Cache term address value -> Evaluator term address value m () putCache = put -- | Run an action starting from an empty out-cache, and return the out-cache afterwards. -isolateCache :: (Member (State (Cache term address value)) sig, Member (State (Heap address address value)) sig, Carrier sig m) +isolateCache :: (Has (State (Cache term address value)) sig m, Has (State (Heap address address value)) sig m) => Evaluator term address value m a -> Evaluator term address value m (Cache term address value, Heap address address value) isolateCache action = putCache lowerBound *> action *> ((,) <$> get <*> get) -- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. -cachingTerms :: ( Member (Reader (Cache term address value)) sig - , Member (Reader (Live address)) sig - , Member (State (Cache term address value)) sig - , Carrier sig m +cachingTerms :: ( Has (Reader (Cache term address value)) sig m + , Has (Reader (Live address)) sig m + , Has (State (Cache term address value)) sig m , Ord address , Ord term , Ord value @@ -73,33 +79,33 @@ cachingTerms recur term = do values <- consultOracle c cachingConfiguration c values (recur term) -convergingModules :: ( Eq value - , Member Fresh sig - , Member (Reader (Cache term address value)) sig - , Member (Reader (Live address)) sig - , Member (State (Cache term address value)) sig - , Member (State (Heap address address value)) sig +convergingModules :: ( Effect sig + , Eq value + , Has Fresh sig m + , Has (Reader (Cache term address value)) sig m + , Has (Reader (Live address)) sig m + , Has (State (Cache term address value)) sig m + , Has (State (Heap address address value)) sig m , Ord address , Ord term - , Carrier sig m , Alternative m ) - => (Module (Either prelude term) -> Evaluator term address value (NonDetC m) value) + => (Module (Either prelude term) -> Evaluator term address value (NonDetC (FreshC m)) value) -> (Module (Either prelude term) -> Evaluator term address value m value) -convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty +convergingModules recur m@(Module _ (Left _)) = raiseHandler (evalFresh 0 . runNonDetA) (recur m) >>= maybeM empty convergingModules recur m@(Module _ (Right term)) = do c <- getConfiguration term heap <- getHeap -- Convergence here is predicated upon an Eq instance, not α-equivalence (cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do -- We need to reset fresh generation so that this invocation converges. - resetFresh $ + raiseHandler (evalFresh 0) $ -- This is subtle: though the calling context supports nondeterminism, we want -- to corral all the nondeterminism that happens in this @eval@ invocation, so -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - withOracle prevCache (raiseHandler (runNonDet @Maybe) (recur m))) + withOracle prevCache (raiseHandler (runNonDetA @Maybe) (recur m))) maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. @@ -118,17 +124,17 @@ converge seed f = loop seed loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Foldable t, Carrier sig m, Alternative m) => t value -> Evaluator term address value m value +scatter :: (Foldable t, Alternative m) => t value -> Evaluator term address value m value scatter = foldMapA pure -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) sig, Carrier sig m) +getConfiguration :: Has (Reader (Live address)) sig m => term -> Evaluator term address value m (Configuration term address) getConfiguration term = Configuration term <$> askRoots -caching :: Carrier sig m +caching :: Algebra sig m => Evaluator term address value (NonDetC (ReaderC (Cache term address value) (StateC (Cache term address value) @@ -138,7 +144,7 @@ caching = raiseHandler (runState lowerBound) . raiseHandler (runReader lowerBound) . fmap (toList @B) - . raiseHandler runNonDet + . raiseHandler runNonDetA data B a = E | L a | B (B a) (B a) deriving (Functor) diff --git a/src/Analysis/Abstract/Caching/FlowSensitive.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs index f77b47b11..ab1a212ba 100644 --- a/src/Analysis/Abstract/Caching/FlowSensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowSensitive.hs @@ -6,19 +6,26 @@ module Analysis.Abstract.Caching.FlowSensitive , caching ) where +import Prologue + +import Control.Algebra (Effect) +import Control.Carrier.NonDet.Church +import Control.Carrier.Reader +import Control.Carrier.Fresh.Strict +import Control.Carrier.State.Strict + import Control.Abstract import Data.Abstract.Module import Data.Map.Monoidal as Monoidal hiding (empty) -import Prologue -- | Look up the set of values for a given configuration in the in-cache. -consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) sig, Carrier sig m) +consultOracle :: (Cacheable term address value, Has (Reader (Cache term address value)) sig m) => Configuration term address value -> Evaluator term address value m (Set (Cached address value)) consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask -- | Run an action with the given in-cache. -withOracle :: (Member (Reader (Cache term address value)) sig, Carrier sig m) +withOracle :: Has (Reader (Cache term address value)) sig m => Cache term address value -> Evaluator term address value m a -> Evaluator term address value m a @@ -26,13 +33,13 @@ withOracle cache = local (const cache) -- | Look up the set of values for a given configuration in the out-cache. -lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) sig, Carrier sig m) +lookupCache :: (Cacheable term address value, Has (State (Cache term address value)) sig m) => Configuration term address value -> Evaluator term address value m (Maybe (Set (Cached address value))) lookupCache configuration = cacheLookup configuration <$> get -- | Run an action, caching its result and 'Heap' under the given configuration. -cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) sig, Member (State (Heap address address value)) sig, Carrier sig m) +cachingConfiguration :: (Cacheable term address value, Has (State (Cache term address value)) sig m, Has (State (Heap address address value)) sig m) => Configuration term address value -> Set (Cached address value) -> Evaluator term address value m value @@ -42,13 +49,13 @@ cachingConfiguration configuration values action = do result <- Cached <$> action <*> getHeap cachedValue result <$ modify (cacheInsert configuration result) -putCache :: (Member (State (Cache term address value)) sig, Carrier sig m) +putCache :: Has (State (Cache term address value)) sig m => Cache term address value -> Evaluator term address value m () putCache = put -- | Run an action starting from an empty out-cache, and return the out-cache afterwards. -isolateCache :: (Member (State (Cache term address value)) sig, Carrier sig m) +isolateCache :: Has (State (Cache term address value)) sig m => Evaluator term address value m a -> Evaluator term address value m (Cache term address value) isolateCache action = putCache lowerBound *> action *> get @@ -56,11 +63,10 @@ isolateCache action = putCache lowerBound *> action *> get -- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. cachingTerms :: ( Cacheable term address value - , Member (Reader (Cache term address value)) sig - , Member (Reader (Live address)) sig - , Member (State (Cache term address value)) sig - , Member (State (Heap address address value)) sig - , Carrier sig m + , Has (Reader (Cache term address value)) sig m + , Has (Reader (Live address)) sig m + , Has (State (Cache term address value)) sig m + , Has (State (Heap address address value)) sig m , Alternative m ) => Open (term -> Evaluator term address value m value) @@ -74,30 +80,30 @@ cachingTerms recur term = do cachingConfiguration c pairs (recur term) convergingModules :: ( Cacheable term address value - , Member Fresh sig - , Member (Reader (Cache term address value)) sig - , Member (Reader (Live address)) sig - , Member (State (Cache term address value)) sig - , Member (State (Heap address address value)) sig - , Carrier sig m + , Effect sig + , Has Fresh sig m + , Has (Reader (Cache term address value)) sig m + , Has (Reader (Live address)) sig m + , Has (State (Cache term address value)) sig m + , Has (State (Heap address address value)) sig m , Alternative m ) - => (Module (Either prelude term) -> Evaluator term address value (NonDetC m) value) + => (Module (Either prelude term) -> Evaluator term address value (NonDetC (FreshC m)) value) -> (Module (Either prelude term) -> Evaluator term address value m value) -convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty +convergingModules recur m@(Module _ (Left _)) = raiseHandler (evalFresh 0 . runNonDetA) (recur m) >>= maybeM empty convergingModules recur m@(Module _ (Right term)) = do c <- getConfiguration term -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge lowerBound (\ prevCache -> isolateCache $ do putHeap (configurationHeap c) -- We need to reset fresh generation so that this invocation converges. - resetFresh $ + raiseHandler (evalFresh 0) $ -- This is subtle: though the calling context supports nondeterminism, we want -- to corral all the nondeterminism that happens in this @eval@ invocation, so -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - withOracle prevCache (raiseHandler (runNonDet @Maybe) (recur m))) + withOracle prevCache (raiseHandler (runNonDetA @Maybe) (recur m))) maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. @@ -116,11 +122,13 @@ converge seed f = loop seed loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Foldable t, Member (State (Heap address address value)) sig, Alternative m, Carrier sig m) => t (Cached address value) -> Evaluator term address value m value +scatter :: (Foldable t, Has (State (Heap address address value)) sig m, Alternative m) + => t (Cached address value) + -> Evaluator term address value m value scatter = foldMapA (\ (Cached value heap') -> putHeap heap' $> value) -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) sig, Member (State (Heap address address value)) sig, Carrier sig m) +getConfiguration :: (Has (Reader (Live address)) sig m, Has (State (Heap address address value)) sig m) => term -> Evaluator term address value m (Configuration term address value) getConfiguration term = Configuration term <$> askRoots <*> getHeap @@ -135,7 +143,7 @@ caching :: Monad m caching = raiseHandler (runState lowerBound) . raiseHandler (runReader lowerBound) - . raiseHandler runNonDet + . raiseHandler runNonDetA -- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's. @@ -144,9 +152,9 @@ newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuratio -- | A single point in a program’s execution. data Configuration term address value = Configuration - { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live address -- ^ The set of rooted addresses. - , configurationHeap :: Heap address address value -- ^ The heap of values. + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live address -- ^ The set of rooted addresses. + , configurationHeap :: Heap address address value -- ^ The heap of values. } deriving (Eq, Ord, Show) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 4a7d11f3c..74dddf163 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -3,6 +3,7 @@ module Analysis.Abstract.Collecting ) where import Control.Abstract +import Control.Carrier.Reader import Prologue providingLiveSet :: Evaluator term address value (ReaderC (Live address) m) a -> Evaluator term address value m a diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 10d8cfd65..578b5e338 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -7,6 +7,7 @@ module Analysis.Abstract.Dead ) where import Control.Abstract +import Control.Carrier.State.Strict import Data.Abstract.Module import Data.Semigroup.Reducer as Reducer import Data.Set (delete) @@ -19,11 +20,11 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: (Member (State (Dead term)) sig, Carrier sig m) => Dead term -> Evaluator term address value m () +killAll :: (Has (State (Dead term)) sig m) => Dead term -> Evaluator term address value m () killAll = put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Member (State (Dead term)) sig, Carrier sig m, Ord term) => term -> Evaluator term address value m () +revive :: (Has (State (Dead term)) sig m, Ord term) => term -> Evaluator term address value m () revive t = modify (Dead . delete t . unDead) -- | Compute the set of all subterms recursively. @@ -31,19 +32,17 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter subterms term = term `cons` para (foldMap (uncurry cons)) term -revivingTerms :: ( Member (State (Dead term)) sig - , Ord term - , Carrier sig m - ) +revivingTerms :: ( Has (State (Dead term)) sig m + , Ord term + ) => Open (term -> Evaluator term address value m a) revivingTerms recur term = revive term *> recur term killingModules :: ( Foldable (Base term) - , Member (State (Dead term)) sig - , Ord term - , Recursive term - , Carrier sig m - ) + , Has (State (Dead term)) sig m + , Ord term + , Recursive term + ) => Open (Module term -> Evaluator term address value m a) killingModules recur m = killAll (subterms (moduleBody m)) *> recur m diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index f62359bb4..8e059a79a 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -18,7 +18,10 @@ module Analysis.Abstract.Graph import Algebra.Graph.Export.Dot hiding (vertexName) import Control.Abstract hiding (Function(..)) -import Control.Effect.Carrier +import Control.Algebra +import Control.Carrier.Reader +import Control.Carrier.State.Strict +import Control.Effect.Sum.Project import Data.Abstract.BaseError import Data.Abstract.Module (Module (moduleInfo), ModuleInfo (..)) import Data.Abstract.Package (PackageInfo (..)) @@ -57,20 +60,19 @@ style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier)) -- | Add vertices to the graph for evaluated identifiers. -graphingTerms :: ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State (Graph ControlFlowVertex)) sig - , Member (State (Map (Slot address) ControlFlowVertex)) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ControlFlowVertex) sig +graphingTerms :: ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State (Graph ControlFlowVertex)) sig m + , Has (State (Map (Slot address) ControlFlowVertex)) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ControlFlowVertex) sig m , VertexDeclaration term , Ord address - , Carrier sig m ) => Open (term Loc -> Evaluator (term Loc) address value m a) graphingTerms recur term = do @@ -96,20 +98,18 @@ graphingTerms recur term = do pure valRef -- | Add vertices to the graph for evaluated modules and the packages containing them. -graphingPackages :: ( Member (Reader PackageInfo) sig - , Member (State (Graph ControlFlowVertex)) sig - , Member (Reader ControlFlowVertex) sig - , Carrier sig m +graphingPackages :: ( Has (Reader PackageInfo) sig m + , Has (State (Graph ControlFlowVertex)) sig m + , Has (Reader ControlFlowVertex) sig m ) => Open (Module term -> m a) graphingPackages recur m = let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m) -- | Add vertices to the graph for imported modules. -graphingModules :: ( Member (Reader ModuleInfo) sig - , Member (State (Graph ControlFlowVertex)) sig - , Member (Reader ControlFlowVertex) sig - , Carrier sig m +graphingModules :: ( Has (Reader ModuleInfo) sig m + , Has (State (Graph ControlFlowVertex)) sig m + , Has (Reader ControlFlowVertex) sig m ) => (Module body -> Evaluator term address value (EavesdropC address value m) a) -> (Module body -> Evaluator term address value m a) @@ -129,9 +129,8 @@ graphingModules recur m = do in moduleInclusion (moduleVertex (ModuleInfo path' (moduleLanguage info) (moduleOid info))) -- | Add vertices to the graph for imported modules. -graphingModuleInfo :: ( Member (Reader ModuleInfo) sig - , Member (State (Graph ModuleInfo)) sig - , Carrier sig m +graphingModuleInfo :: ( Has (Reader ModuleInfo) sig m + , Has (State (Graph ModuleInfo)) sig m ) => (Module body -> Evaluator term address value (EavesdropC address value m) a) -> (Module body -> Evaluator term address value m a) @@ -154,15 +153,14 @@ newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address v 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' = hmap (runEavesdropC handler) eff in handler eff' *> send eff') - | otherwise = EavesdropC (\ handler -> eff (hmap (runEavesdropC handler) op)) +instance (Has (Modules address value) sig m, Project (Modules address value) sig, Applicative m) => Algebra sig (EavesdropC address value m) where + alg op + | Just alg <- prj op = EavesdropC (\ handler -> let eff' = hmap (runEavesdropC handler) alg in handler eff' *> send eff') + | otherwise = EavesdropC (\ handler -> alg (hmap (runEavesdropC handler) op)) -- | Add an edge from the current package to the passed vertex. -packageInclusion :: ( Member (Reader PackageInfo) sig - , Member (State (Graph ControlFlowVertex)) sig - , Carrier sig m +packageInclusion :: ( Has (Reader PackageInfo) sig m + , Has (State (Graph ControlFlowVertex)) sig m ) => ControlFlowVertex -> m () @@ -171,9 +169,8 @@ packageInclusion v = do appendGraph (vertex (packageVertex p) `connect` vertex v) -- | Add an edge from the current module to the passed vertex. -moduleInclusion :: ( Member (Reader ModuleInfo) sig - , Member (State (Graph ControlFlowVertex)) sig - , Carrier sig m +moduleInclusion :: ( Has (Reader ModuleInfo) sig m + , Has (State (Graph ControlFlowVertex)) sig m ) => ControlFlowVertex -> m () @@ -182,9 +179,8 @@ moduleInclusion v = do appendGraph (vertex (moduleVertex m) `connect` vertex v) -- | Add an edge from the passed variable name to the context it originated within. -variableDefinition :: ( Member (State (Graph ControlFlowVertex)) sig - , Member (Reader ControlFlowVertex) sig - , Carrier sig m +variableDefinition :: ( Has (State (Graph ControlFlowVertex)) sig m + , Has (Reader ControlFlowVertex) sig m ) => ControlFlowVertex -> m () @@ -192,11 +188,11 @@ variableDefinition var = do context <- ask appendGraph (vertex context `connect` vertex var) -appendGraph :: (Member (State (Graph v)) sig, Carrier sig m) => Graph v -> m () +appendGraph :: Has (State (Graph v)) sig m => Graph v -> m () appendGraph = modify . (<>) -graphing :: Carrier sig m +graphing :: Algebra sig m => Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex) (StateC (Graph ControlFlowVertex) m)) result diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 598cbc7b4..06bd470fb 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -5,36 +5,33 @@ module Analysis.Abstract.Tracing ) where import Control.Abstract hiding (trace) -import Control.Effect.Writer +import Control.Carrier.Writer.Strict import Data.Semigroup.Reducer as Reducer -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -tracingTerms :: ( Member (State (Heap address address value)) sig - , Member (Writer (trace (Configuration term address value))) sig - , Carrier sig m - , Reducer (Configuration term address value) (trace (Configuration term address value)) - ) +tracingTerms :: ( Has (State (Heap address address value)) sig m + , Has (Writer (trace (Configuration term address value))) sig m + , Reducer (Configuration term address value) (trace (Configuration term address value)) + ) => trace (Configuration term address value) -> Open (term -> Evaluator term address value m a) tracingTerms proxy recur term = getConfiguration term >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term -trace :: ( Member (Writer (trace (Configuration term address value))) sig - , Carrier sig m - ) +trace :: Has (Writer (trace (Configuration term address value))) sig m => trace (Configuration term address value) -> Evaluator term address value m () trace = tell -tracing :: (Monoid (trace (Configuration term address value))) +tracing :: Monoid (trace (Configuration term address value)) => Evaluator term address value (WriterC (trace (Configuration term address value)) (Evaluator term address value m)) a -> Evaluator term address value m (trace (Configuration term address value), a) tracing = runWriter . runEvaluator -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (State (Heap address address value)) sig, Carrier sig m) +getConfiguration :: Has (State (Heap address address value)) sig m => term -> Evaluator term address value m (Configuration term address value) getConfiguration term = Configuration term <$> getHeap diff --git a/src/Control/Abstract/Context.hs b/src/Control/Abstract/Context.hs index 3b129fd46..9b1cef723 100644 --- a/src/Control/Abstract/Context.hs +++ b/src/Control/Abstract/Context.hs @@ -22,38 +22,38 @@ import Prologue import Source.Span -- | Get the currently evaluating 'ModuleInfo'. -currentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => m ModuleInfo +currentModule :: (Has (Reader ModuleInfo) sig m) => m ModuleInfo currentModule = ask -- | Run an action with a locally-replaced 'ModuleInfo'. -withCurrentModule :: (Member (Reader ModuleInfo) sig, Carrier sig m) => ModuleInfo -> m a -> m a +withCurrentModule :: Has (Reader ModuleInfo) sig m => ModuleInfo -> m a -> m a withCurrentModule = local . const -- | Get the currently evaluating 'PackageInfo'. -currentPackage :: (Member (Reader PackageInfo) sig, Carrier sig m) => m PackageInfo +currentPackage :: Has (Reader PackageInfo) sig m => m PackageInfo currentPackage = ask -- | Run an action with a locally-replaced 'PackageInfo'. -withCurrentPackage :: (Member (Reader PackageInfo) sig, Carrier sig m) => PackageInfo -> m a -> m a +withCurrentPackage :: Has (Reader PackageInfo) sig m => PackageInfo -> m a -> m a withCurrentPackage = local . const -- | Get the 'Span' of the currently-evaluating term (if any). -currentSpan :: (Member (Reader Span) sig, Carrier sig m) => m Span +currentSpan :: Has (Reader Span) sig m => m Span currentSpan = ask -- | Run an action with a locally-replaced 'Span'. -withCurrentSpan :: (Member (Reader Span) sig, Carrier sig m) => Span -> m a -> m a +withCurrentSpan :: Has (Reader Span) sig m => Span -> m a -> m a withCurrentSpan = local . const -modifyChildSpan :: (Member (State Span) sig, Carrier sig m) => Span -> m a -> m a +modifyChildSpan :: Has (State Span) sig m => Span -> m a -> m a modifyChildSpan span m = m <* put span -- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'. -withCurrentSrcLoc :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => SrcLoc -> m a -> m a +withCurrentSrcLoc :: (Has (Reader ModuleInfo) sig m, Has (Reader Span) sig m) => SrcLoc -> m a -> m a withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc) -- | Run an action with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack. -- -- This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source. -withCurrentCallStack :: (Member (Reader ModuleInfo) sig, Member (Reader Span) sig, Carrier sig m) => CallStack -> m a -> m a +withCurrentCallStack :: (Has (Reader ModuleInfo) sig m, Has (Reader Span) sig m) => CallStack -> m a -> m a withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 8835852f8..44729d6f5 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -17,7 +17,8 @@ module Control.Abstract.Evaluator , module X ) where -import Control.Effect.Carrier +import Control.Algebra +import Control.Carrier.Error.Either import Control.Effect.Error as X import Control.Effect.Fresh as X import Control.Effect.NonDet as X @@ -36,8 +37,8 @@ import Data.Coerce newtype Evaluator term address value m a = Evaluator { runEvaluator :: m a } deriving (Alternative, Applicative, Functor, Monad, MonadIO) -instance Carrier sig m => Carrier sig (Evaluator term address value m) where - eff = Evaluator . eff . handleCoercible +instance Algebra sig m => Algebra sig (Evaluator term address value m) where + alg = Evaluator . alg . handleCoercible -- | Raise a handler on monads into a handler on 'Evaluator's over those monads. raiseHandler :: (m a -> n b) @@ -56,19 +57,17 @@ type Open a = a -> a newtype Return value = Return { unReturn :: value } deriving (Eq, Ord, Show) -earlyReturn :: ( Member (Error (Return value)) sig - , Carrier sig m - ) +earlyReturn :: Has (Throw (Return value)) sig m => value -> Evaluator term address value m value earlyReturn = throwError . Return -catchReturn :: (Member (Error (Return value)) sig, Carrier sig m) +catchReturn :: Has (Catch (Return value)) sig m => Evaluator term address value m value -> Evaluator term address value m value catchReturn = flip catchError (\ (Return value) -> pure value) -runReturn :: Carrier sig m +runReturn :: Algebra sig m => Evaluator term address value (ErrorC (Return value) m) value -> Evaluator term address value m value runReturn = raiseHandler $ fmap (either unReturn id) . runError @@ -87,29 +86,27 @@ unLoopControl = \case Continue v -> v Abort -> error "unLoopControl: Abort" -throwBreak :: (Member (Error (LoopControl value)) sig, Carrier sig m) +throwBreak :: Has (Error (LoopControl value)) sig m => value -> Evaluator term address value m value throwBreak = throwError . Break -throwContinue :: (Member (Error (LoopControl value)) sig, Carrier sig m) +throwContinue :: Has (Error (LoopControl value)) sig m => value -> Evaluator term address value m value throwContinue = throwError . Continue -throwAbort :: forall term address sig m value a . (Member (Error (LoopControl value)) sig, Carrier sig m) +throwAbort :: forall term address sig m value a . Has (Error (LoopControl value)) sig m => Evaluator term address value m a throwAbort = throwError (Abort @value) -catchLoopControl :: ( Member (Error (LoopControl value)) sig - , Carrier sig m - ) +catchLoopControl :: Has (Error (LoopControl value)) sig m => Evaluator term address value m a -> (LoopControl value -> Evaluator term address value m a) -> Evaluator term address value m a catchLoopControl = catchError -runLoopControl :: Carrier sig m +runLoopControl :: Algebra sig m => Evaluator term address value (ErrorC (LoopControl value) m) value -> Evaluator term address value m value runLoopControl = raiseHandler $ fmap (either unLoopControl id) . runError diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 8e706efde..0ee974623 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -47,8 +47,11 @@ import Control.Abstract.Evaluator import Control.Abstract.Roots import Control.Abstract.ScopeGraph hiding (ScopeError (..)) import Control.Abstract.ScopeGraph (ScopeError) +import Control.Algebra import Control.Applicative (Alternative) -import Control.Effect.Carrier +import qualified Control.Carrier.Resumable.Resume as With +import Control.Carrier.Resumable.Either (SomeError (..)) +import qualified Control.Carrier.Resumable.Either as Either import Data.Abstract.BaseError import Data.Abstract.Heap (Heap, Position (..)) import qualified Data.Abstract.Heap as Heap @@ -63,13 +66,12 @@ import Source.Span (Span) -- | Evaluates an action locally the scope and frame of the given frame address. withScopeAndFrame :: ( Ord address - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (State (Heap address address value)) sig - , Carrier sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (State (Heap address address value)) sig m ) => address -> Evaluator term address value m a @@ -80,16 +82,15 @@ withScopeAndFrame address action = do -- | Evaluates an action locally the scope and frame of the given frame address. withLexicalScopeAndFrame :: ( Ord address - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Allocator address) sig - , Member Fresh sig - , Carrier sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Allocator address) sig m + , Has Fresh sig m ) => Evaluator term address value m a -> Evaluator term address value m a @@ -103,42 +104,39 @@ withLexicalScopeAndFrame action = do -- | Lookup a scope address for a given frame address. scopeLookup :: ( Ord address - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (State (Heap address address value)) sig - , Carrier sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (State (Heap address address value)) sig m + ) => address -> Evaluator term address value m address scopeLookup address = maybeM (throwHeapError (LookupAddressError address)) =<< Heap.scopeLookup address <$> getHeap -getHeap :: (Member (State (Heap address address value)) sig, Carrier sig m) => Evaluator term address value m (Heap address address value) +getHeap :: Has (State (Heap address address value)) sig m => Evaluator term address value m (Heap address address value) getHeap = get -- | Set the heap. -putHeap :: (Member (State (Heap address address value)) sig, Carrier sig m) => Heap address address value -> Evaluator term address value m () +putHeap :: Has (State (Heap address address value)) sig m => Heap address address value -> Evaluator term address value m () putHeap = put -- | Update the heap. -modifyHeap :: (Member (State (Heap address address value)) sig, Carrier sig m) => (Heap address address value -> Heap address address value) -> Evaluator term address value m () +modifyHeap :: Has (State (Heap address address value)) sig m => (Heap address address value -> Heap address address value) -> Evaluator term address value m () modifyHeap = modify newtype CurrentFrame address = CurrentFrame { unCurrentFrame :: address } -- | Retrieve the heap. -currentFrame :: ( Carrier sig m - , Member (Reader (CurrentFrame address)) sig - ) +currentFrame :: Has (Reader (CurrentFrame address)) sig m => Evaluator term address value m address currentFrame = asks unCurrentFrame -- | Inserts a new frame into the heap with the given scope and links. -newFrame :: ( Carrier sig m - , Member (Allocator address) sig - , Member Fresh sig - , Member (State (Heap address address value)) sig +newFrame :: ( Has (Allocator address) sig m + , Has Fresh sig m + , Has (State (Heap address address value)) sig m , Ord address ) => address @@ -151,9 +149,7 @@ newFrame scope links = do pure address -- | Evaluates the action within the frame of the given frame address. -withFrame :: ( Carrier sig m - , Member (Reader (CurrentFrame address)) sig - ) +withFrame :: Has (Reader (CurrentFrame address)) sig m => address -> Evaluator term address value m a -- Not sure about this `sig` here (substituting `sig` for `effects`) -> Evaluator term address value m a @@ -161,17 +157,16 @@ withFrame address = local (const (CurrentFrame address)) -- | Define a declaration and assign the value of an action in the current frame. define :: ( HasCallStack - , Member (Deref value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig + , Has (Deref value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m , Ord address - , Carrier sig m ) => Declaration -> Relation @@ -186,17 +181,16 @@ define declaration rel accessControl def = withCurrentCallStack callStack $ do assign slot value -- | Associate an empty child scope with a declaration and then locally evaluate the body within an associated frame. -withChildFrame :: ( Member (Allocator address) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member Fresh sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig +withChildFrame :: ( Has (Allocator address) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has Fresh sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m , Ord address - , Carrier sig m ) => Declaration -> (address -> Evaluator term address value m a) @@ -208,13 +202,12 @@ withChildFrame declaration body = do withScopeAndFrame frame (body frame) -- | Dereference the given address in the heap, or fail if the address is uninitialized. -deref :: ( Member (Deref value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (AddressError address value))) sig - , Member (State (Heap address address value)) sig +deref :: ( Has (Deref value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (AddressError address value))) sig m + , Has (State (Heap address address value)) sig m , Ord address - , Carrier sig m ) => Slot address -> Evaluator term address value m value @@ -224,13 +217,12 @@ deref slot@Slot{..} = do eff <- send $ DerefCell slotValue pure maybeM (throwAddressError $ UninitializedSlot slot) eff -putSlotDeclarationScope :: ( Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig +putSlotDeclarationScope :: ( Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m , Ord address - , Carrier sig m ) => Slot address -> Maybe address @@ -240,14 +232,13 @@ putSlotDeclarationScope Slot{..} assocScope = do modify (putDeclarationScopeAtPosition scopeAddress position assocScope) -maybeLookupDeclaration :: ( Carrier sig m - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig +maybeLookupDeclaration :: ( Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m , Ord address ) => Declaration @@ -260,34 +251,32 @@ maybeLookupDeclaration decl = do pure (Just (Slot frameAddress (Heap.pathPosition path))) Nothing -> pure Nothing -lookupSlot :: ( Carrier sig m - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Ord address - ) - => Declaration - -> Evaluator term address value m (Slot address) +lookupSlot :: ( Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Ord address + ) + => Declaration + -> Evaluator term address value m (Slot address) lookupSlot decl = do path <- lookupScopePath decl frameAddress <- lookupFrameAddress path pure (Slot frameAddress (Heap.pathPosition path)) -lookupDeclarationFrame :: ( Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig +lookupDeclarationFrame :: ( Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m , Ord address - , Carrier sig m ) => Declaration -> Evaluator term address value m address @@ -295,12 +284,11 @@ lookupDeclarationFrame decl = do path <- lookupScopePath decl lookupFrameAddress path -lookupFrame :: ( Member (State (Heap address address value)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig +lookupFrame :: ( Has (State (Heap address address value)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m , Ord address - , Carrier sig m ) => address -> Evaluator term address value m (Heap.Frame address address value) @@ -309,13 +297,12 @@ lookupFrame address = do maybeM (throwHeapError (LookupFrameError address)) (Heap.frameLookup address heap) -- | Follow a path through the heap and return the frame address associated with the declaration. -lookupFrameAddress :: ( Member (State (Heap address address value)) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig +lookupFrameAddress :: ( Has (State (Heap address address value)) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m , Ord address - , Carrier sig m ) => Path address -> Evaluator term address value m address @@ -331,11 +318,10 @@ lookupFrameAddress path = go path =<< currentFrame Map.lookup nextScopeAddress scopeMap maybe (throwHeapError $ LookupLinkError p) (go path') frameAddress -frameLinks :: ( Carrier sig m - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (State (Heap address address value)) sig +frameLinks :: ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (State (Heap address address value)) sig m , Ord address ) => address @@ -343,12 +329,11 @@ frameLinks :: ( Carrier sig m frameLinks address = maybeM (throwHeapError (LookupLinksError address)) . Heap.frameLinks address =<< getHeap -insertFrameLink :: ( Carrier sig m - , Member (Reader (CurrentFrame address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (State (Heap address address value)) sig +insertFrameLink :: ( Has (Reader (CurrentFrame address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (State (Heap address address value)) sig m , Ord address ) => EdgeLabel @@ -364,10 +349,9 @@ insertFrameLink label linkMap = do -- | Write a value to the given frame address in the 'Heap'. -assign :: ( Member (Deref value) sig - , Member (State (Heap address address value)) sig +assign :: ( Has (Deref value) sig m + , Has (State (Heap address address value)) sig m , Ord address - , Carrier sig m ) => Slot address -> value @@ -377,8 +361,7 @@ assign addr value = do cell <- send (AssignCell value (fromMaybe lowerBound (Heap.getSlotValue addr heap)) pure) putHeap (Heap.setSlot addr cell heap) -dealloc :: ( Carrier sig m - , Member (State (Heap address address value)) sig +dealloc :: ( Has (State (Heap address address value)) sig m , Ord address ) => Slot address @@ -389,11 +372,10 @@ dealloc addr = modifyHeap (Heap.deleteSlot addr) -- Garbage collection -- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set. -gc :: ( Member (State (Heap address address value)) sig +gc :: ( Has (State (Heap address address value)) sig m , Ord address , Ord value , ValueRoots address value - , Carrier sig m ) => Live address -- ^ The set of addresses to consider rooted. -> Evaluator term address value m () @@ -454,23 +436,22 @@ instance Eq address => Eq1 (HeapError address) where liftEq _ (LookupFrameError a) (LookupFrameError b) = a == b liftEq _ _ _ = False -throwHeapError :: ( Member (Resumable (BaseError (HeapError address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Carrier sig m +throwHeapError :: ( Has (Resumable (BaseError (HeapError address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m ) => HeapError address resume -> Evaluator term address value m resume throwHeapError = throwBaseError -runHeapError :: Evaluator term address value (ResumableC (BaseError (HeapError address)) m) a +runHeapError :: Evaluator term address value (Either.ResumableC (BaseError (HeapError address)) m) a -> Evaluator term address value m (Either (SomeError (BaseError (HeapError address))) a) -runHeapError = raiseHandler runResumable +runHeapError = raiseHandler Either.runResumable runHeapErrorWith :: (forall resume. (BaseError (HeapError address)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (HeapError address)) m) a + -> Evaluator term address value (With.ResumableC (BaseError (HeapError address)) m) a -> Evaluator term address value m a -runHeapErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) +runHeapErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) data AddressError address value resume where UnallocatedSlot :: Slot address -> AddressError address value (Set value) @@ -485,20 +466,19 @@ instance Eq address => Eq1 (AddressError address value) where liftEq _ (UnallocatedSlot a) (UnallocatedSlot b) = a == b liftEq _ _ _ = False -throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Carrier sig m +throwAddressError :: ( Has (Resumable (BaseError (AddressError address body))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m ) => AddressError address body resume -> Evaluator term address value m resume throwAddressError = throwBaseError -runAddressError :: Evaluator term address value (ResumableC (BaseError (AddressError address value)) m) a +runAddressError :: Evaluator term address value (Either.ResumableC (BaseError (AddressError address value)) m) a -> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a) -runAddressError = raiseHandler runResumable +runAddressError = raiseHandler Either.runResumable runAddressErrorWith :: (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) m) a + -> Evaluator term address value (With.ResumableC (BaseError (AddressError address value)) m) a -> Evaluator term address value m a -runAddressErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) +runAddressErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index de2ab3a15..2362750d2 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, + KindSignatures, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeOperators, + UndecidableInstances #-} module Control.Abstract.Modules ( ModuleResult , lookupModule @@ -19,16 +21,21 @@ module Control.Abstract.Modules , ModuleTable ) where +import Prologue + +import Control.Algebra +import Control.Carrier.Reader +import qualified Control.Carrier.Resumable.Either as Either +import qualified Control.Carrier.Resumable.Resume as With +import qualified Data.Set as Set +import Source.Span +import System.FilePath.Posix (takeDirectory) + import Control.Abstract.Evaluator -import Control.Effect.Carrier import Data.Abstract.BaseError import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Language -import qualified Data.Set as Set -import Prologue -import Source.Span -import System.FilePath.Posix (takeDirectory) -- | A scope address, frame address, and value ref. -- @@ -36,27 +43,27 @@ import System.FilePath.Posix (takeDirectory) type ModuleResult address = (,) (address, address) -- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load. -lookupModule :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address value)) +lookupModule :: Has (Modules address value) sig m => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address value)) lookupModule = sendModules . flip Lookup pure -- | Resolve a list of module paths to a possible module table entry. -resolve :: (Member (Modules address value) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath) +resolve :: Has (Modules address value) sig m => [FilePath] -> Evaluator term address value m (Maybe ModulePath) resolve = sendModules . flip Resolve pure -listModulesInDir :: (Member (Modules address value) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath] +listModulesInDir :: Has (Modules address value) sig m => FilePath -> Evaluator term address value m [ModulePath] listModulesInDir = sendModules . flip List pure -- | Require/import another module by name and return its environment and value. -- -- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. -require :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address value) +require :: Has (Modules address value) sig m => ModulePath -> Evaluator term address value m (ModuleResult address value) require path = lookupModule path >>= maybeM (load path) -- | Load another module by name and return its environment and value. -- -- Always loads/evaluates. -load :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address value) +load :: Has (Modules address value) sig m => ModulePath -> Evaluator term address value m (ModuleResult address value) load path = sendModules (Load path pure) @@ -71,8 +78,7 @@ instance HFunctor (Modules address value) instance Effect (Modules address value) -sendModules :: ( Member (Modules address value) sig - , Carrier sig m) +sendModules :: Has (Modules address value) sig m => Modules address value (Evaluator term address value m) return -> Evaluator term address value m return sendModules = send @@ -85,21 +91,20 @@ runModules paths = raiseHandler (runReader paths . runModulesC) newtype ModulesC address value m a = ModulesC { runModulesC :: ReaderC (Set ModulePath) m a } deriving (Alternative, Applicative, Functor, Monad, MonadIO) -instance ( Member (Reader (ModuleTable (Module (ModuleResult address value)))) sig - , Member (Resumable (BaseError (LoadError address value))) sig - , Carrier sig m +instance ( Has (Reader (ModuleTable (Module (ModuleResult address value)))) sig m + , Has (Resumable (BaseError (LoadError address value))) sig m ) - => Carrier (Modules address value :+: sig) (ModulesC address value m) where - eff (L op) = do + => Algebra (Modules address value :+: sig) (ModulesC address value m) where + alg (L op) = do paths <- ModulesC ask case op of Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= k Lookup path k -> askModuleTable >>= k . fmap moduleBody . ModuleTable.lookup path Resolve names k -> k (find (`Set.member` paths) names) List dir k -> k (filter ((dir ==) . takeDirectory) (toList paths)) - eff (R other) = ModulesC (eff (R (handleCoercible other))) + alg (R other) = ModulesC (alg (R (handleCoercible other))) -askModuleTable :: (Member (Reader (ModuleTable (Module (ModuleResult address value)))) sig, Carrier sig m) => m (ModuleTable (Module (ModuleResult address value))) +askModuleTable :: Has (Reader (ModuleTable (Module (ModuleResult address value)))) sig m => m (ModuleTable (Module (ModuleResult address value))) askModuleTable = ask @@ -114,16 +119,16 @@ instance Show1 (LoadError address value) where instance Eq1 (LoadError address value) where liftEq _ (ModuleNotFoundError a) (ModuleNotFoundError b) = a == b -runLoadError :: Evaluator term address value (ResumableC (BaseError (LoadError address value)) m) a - -> Evaluator term address value m (Either (SomeError (BaseError (LoadError address value))) a) -runLoadError = raiseHandler runResumable +runLoadError :: Evaluator term address value (Either.ResumableC (BaseError (LoadError address value)) m) a + -> Evaluator term address value m (Either (Either.SomeError (BaseError (LoadError address value))) a) +runLoadError = raiseHandler Either.runResumable runLoadErrorWith :: (forall resume . (BaseError (LoadError address value)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) m) a + -> Evaluator term address value (With.ResumableC (BaseError (LoadError address value)) m) a -> Evaluator term address value m a -runLoadErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) +runLoadErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) -throwLoadError :: (Member (Resumable (BaseError (LoadError address value))) sig, Carrier sig m) +throwLoadError :: Has (Resumable (BaseError (LoadError address value))) sig m => LoadError address value resume -> m resume throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name Unknown mempty) lowerBound err @@ -144,22 +149,21 @@ deriving instance Show (ResolutionError b) instance Show1 ResolutionError where liftShowsPrec _ _ = showsPrec instance Eq1 ResolutionError where liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2 - liftEq _ (GoImportError a) (GoImportError b) = a == b - liftEq _ _ _ = False + liftEq _ (GoImportError a) (GoImportError b) = a == b + liftEq _ _ _ = False -runResolutionError :: Evaluator term address value (ResumableC (BaseError ResolutionError) m) a - -> Evaluator term address value m (Either (SomeError (BaseError ResolutionError)) a) -runResolutionError = raiseHandler runResumable +runResolutionError :: Evaluator term address value (Either.ResumableC (BaseError ResolutionError) m) a + -> Evaluator term address value m (Either (Either.SomeError (BaseError ResolutionError)) a) +runResolutionError = raiseHandler Either.runResumable runResolutionErrorWith :: (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) m) a + -> Evaluator term address value (With.ResumableC (BaseError ResolutionError) m) a -> Evaluator term address value m a -runResolutionErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) +runResolutionErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) -throwResolutionError :: ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Carrier sig m +throwResolutionError :: ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m ) => ResolutionError resume -> Evaluator term address value m resume diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index bb69ddfe4..9932974d2 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -17,20 +17,19 @@ import Data.Map.Strict as Map import Prologue defineBuiltIn :: ( HasCallStack - , Member (Deref value) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Function term address value) sig - , Member (Allocator address) sig - , Member Fresh sig + , Has (Deref value) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Function term address value) sig m + , Has (Allocator address) sig m + , Has Fresh sig m , Ord address - , Carrier sig m ) => Declaration -> Relation @@ -52,20 +51,19 @@ defineBuiltIn declaration rel accessControl value = withCurrentCallStack callSta value <- builtIn associatedScope value assign slot value -defineClass :: ( Carrier sig m - , HasCallStack - , Member (Allocator address) sig - , Member (Deref value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member Fresh sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Unit value) sig +defineClass :: ( HasCallStack + , Has (Allocator address) sig m + , Has (Deref value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has Fresh sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Unit value) sig m , Ord address ) => Declaration @@ -89,19 +87,18 @@ defineClass declaration superclasses body = void . define declaration Default Pu unit defineNamespace :: ( AbstractValue term address value m - , Carrier sig m , HasCallStack - , Member (Allocator address) sig - , Member (Deref value) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member Fresh sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig + , Has (Allocator address) sig m + , Has (Deref value) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has Fresh sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m , Ord address ) => Declaration diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 165ea0c8f..291a16fe8 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -3,7 +3,8 @@ module Control.Abstract.PythonPackage ( runPythonPackaging, Strategy(..) ) where import Control.Abstract as Abstract -import Control.Effect.Carrier +import Control.Algebra +import Control.Effect.Sum.Project import Data.Abstract.Name (name) import Data.Abstract.Path (stripQuotes) import Data.Abstract.Value.Concrete (Value (..)) @@ -24,14 +25,15 @@ newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagin wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address m a wrap = PythonPackagingC . runEvaluator -instance ( Carrier sig m - , Member (Function term address (Value term address)) sig - , Member (State Strategy) sig - , Member (Abstract.String (Value term address)) sig - , Member (Abstract.Array (Value term address)) sig +instance ( Algebra sig m + , Project (Function term address (Value term address)) sig + , Has (Function term address (Value term address)) sig m + , Has (State Strategy) sig m + , Has (Abstract.String (Value term address)) sig m + , Has (Abstract.Array (Value term address)) sig m ) - => Carrier sig (PythonPackagingC term address m) where - eff op + => Algebra sig (PythonPackagingC term address m) where + alg op | Just e <- prj op = wrap $ case handleCoercible e of Call callName params k -> Evaluator . k =<< do case callName of @@ -55,4 +57,4 @@ instance ( Carrier sig m Function name params body scope k -> function name params body scope >>= Evaluator . k BuiltIn n b k -> builtIn n b >>= Evaluator . k Bind obj value k -> bindThis obj value >>= Evaluator . k - | otherwise = PythonPackagingC . eff $ handleCoercible op + | otherwise = PythonPackagingC . alg $ handleCoercible op diff --git a/src/Control/Abstract/Roots.hs b/src/Control/Abstract/Roots.hs index 6835f8c28..5f219a027 100644 --- a/src/Control/Abstract/Roots.hs +++ b/src/Control/Abstract/Roots.hs @@ -15,9 +15,9 @@ class ValueRoots address value where valueRoots :: value -> Live address -- | Retrieve the local 'Live' set. -askRoots :: (Member (Reader (Live address)) sig, Carrier sig m) => Evaluator term address value m (Live address) +askRoots :: Has (Reader (Live address)) sig m => Evaluator term address value m (Live address) askRoots = ask -- | Run a computation with the given 'Live' set added to the local root set. -extraRoots :: (Member (Reader (Live address)) sig, Carrier sig m, Ord address) => Live address -> Evaluator term address value m a -> Evaluator term address value m a +extraRoots :: (Has (Reader (Live address)) sig m, Ord address) => Live address -> Evaluator term address value m a -> Evaluator term address value m a extraRoots roots = local (<> roots) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index b9174e098..a02af4346 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -44,7 +44,9 @@ module Control.Abstract.ScopeGraph ) where import Control.Abstract.Evaluator hiding (Local) -import Control.Effect.Carrier +import Control.Algebra +import qualified Control.Carrier.Resumable.Resume as With +import qualified Control.Carrier.Resumable.Either as Either import Data.Abstract.BaseError import Data.Abstract.Module import Data.Abstract.Name hiding (name) @@ -55,16 +57,15 @@ import Prologue import Source.Span lookup :: ( Ord address - , Member (State (ScopeGraph address)) sig - , Carrier sig m) + , Has (State (ScopeGraph address)) sig m + ) => Reference -> Evaluator term address value m (Maybe address) lookup ref = ScopeGraph.scopeOfRef ref <$> get -declare :: ( Carrier sig m - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig +declare :: ( Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m , Ord address ) => Declaration @@ -81,11 +82,10 @@ declare decl rel accessControl span kind scope = do -- | If the provided name is 'Nothing' we want to reflect that the declaration's name was a generated name (gensym). -- We use the 'Gensym' relation to indicate that. Otherwise, we use the provided 'relation'. -declareMaybeName :: ( Carrier sig m - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member Fresh sig +declareMaybeName :: ( Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has Fresh sig m , Ord address ) => Maybe Name @@ -101,9 +101,8 @@ declareMaybeName maybeName relation ac span kind scope = do _ -> gensym >>= \name -> declare (Declaration name) Gensym ac span kind scope >> pure name putDeclarationScope :: ( Ord address - , Member (Reader (CurrentScope address)) sig - , Member (State (ScopeGraph address)) sig - , Carrier sig m + , Has (Reader (CurrentScope address)) sig m + , Has (State (ScopeGraph address)) sig m ) => Declaration -> address @@ -114,8 +113,7 @@ putDeclarationScope decl assocScope = do putDeclarationSpan :: forall address sig m term value . ( Ord address - , Member (State (ScopeGraph address)) sig - , Carrier sig m + , Has (State (ScopeGraph address)) sig m ) => Declaration -> Span @@ -124,10 +122,9 @@ putDeclarationSpan decl = modify @(ScopeGraph address) . ScopeGraph.insertDeclar reference :: forall address sig m term value . ( Ord address - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Carrier sig m + , Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m ) => Reference -> Span @@ -140,26 +137,25 @@ reference ref span kind decl = do modify @(ScopeGraph address) (ScopeGraph.reference ref moduleInfo span kind decl currentAddress) -- | Combinator to insert an export edge from the current scope to the provided scope address. -insertExportEdge :: (Member (Reader (CurrentScope scopeAddress)) sig, Member (State (ScopeGraph scopeAddress)) sig, Carrier sig m, Ord scopeAddress) +insertExportEdge :: (Has (Reader (CurrentScope scopeAddress)) sig m, Has (State (ScopeGraph scopeAddress)) sig m, Ord scopeAddress) => scopeAddress -> Evaluator term scopeAddress value m () insertExportEdge = insertEdge ScopeGraph.Export -- | Combinator to insert an import edge from the current scope to the provided scope address. -insertImportEdge :: (Member (Reader (CurrentScope scopeAddress)) sig, Member (State (ScopeGraph scopeAddress)) sig, Carrier sig m, Ord scopeAddress) +insertImportEdge :: (Has (Reader (CurrentScope scopeAddress)) sig m, Has (State (ScopeGraph scopeAddress)) sig m, Ord scopeAddress) => scopeAddress -> Evaluator term scopeAddress value m () insertImportEdge = insertEdge ScopeGraph.Import -- | Combinator to insert a lexical edge from the current scope to the provided scope address. -insertLexicalEdge :: (Member (Reader (CurrentScope scopeAddress)) sig, Member (State (ScopeGraph scopeAddress)) sig, Carrier sig m, Ord scopeAddress) +insertLexicalEdge :: (Has (Reader (CurrentScope scopeAddress)) sig m, Has (State (ScopeGraph scopeAddress)) sig m, Ord scopeAddress) => scopeAddress -> Evaluator term scopeAddress value m () insertLexicalEdge = insertEdge ScopeGraph.Lexical -insertEdge :: ( Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentScope address)) sig - , Carrier sig m +insertEdge :: ( Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentScope address)) sig m , Ord address) => EdgeLabel -> address @@ -169,10 +165,9 @@ insertEdge label target = do modify (ScopeGraph.insertEdge label target currentAddress) -- | Inserts a new scope into the scope graph with the given edges. -newScope :: ( Member (Allocator address) sig - , Member (State (ScopeGraph address)) sig - , Member Fresh sig - , Carrier sig m +newScope :: ( Has (Allocator address) sig m + , Has (State (ScopeGraph address)) sig m + , Has Fresh sig m , Ord address ) => Map EdgeLabel [address] @@ -184,10 +179,9 @@ newScope edges = do address <$ modify (ScopeGraph.newScope address edges) -- | Inserts a new scope into the scope graph with the given edges. -newPreludeScope :: ( Member (Allocator address) sig - , Member (State (ScopeGraph address)) sig - , Member Fresh sig - , Carrier sig m +newPreludeScope :: ( Has (Allocator address) sig m + , Has (State (ScopeGraph address)) sig m + , Has Fresh sig m , Ord address ) => Map EdgeLabel [address] @@ -200,25 +194,21 @@ newPreludeScope edges = do newtype CurrentScope address = CurrentScope { unCurrentScope :: address } -currentScope :: ( Carrier sig m - , Member (Reader (CurrentScope address)) sig - ) +currentScope :: Has (Reader (CurrentScope address)) sig m => Evaluator term address value m address currentScope = asks unCurrentScope -lookupScope :: ( Member (Resumable (BaseError (ScopeError address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State (ScopeGraph address)) sig - , Carrier sig m - , Ord address - ) +lookupScope :: ( Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State (ScopeGraph address)) sig m + , Ord address + ) => address -> Evaluator term address value m (Scope address) lookupScope address = maybeM (throwScopeError LookupScopeError) . ScopeGraph.lookupScope address =<< get -declarationsByRelation :: ( Member (State (ScopeGraph address)) sig - , Carrier sig m +declarationsByRelation :: ( Has (State (ScopeGraph address)) sig m , Ord address ) => address @@ -226,11 +216,10 @@ declarationsByRelation :: ( Member (State (ScopeGraph address)) sig -> Evaluator term address value m [ Info address ] declarationsByRelation scope relation = ScopeGraph.declarationsByRelation scope relation <$> get -declarationByName :: ( Member (Resumable (BaseError (ScopeError address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State (ScopeGraph address)) sig - , Carrier sig m +declarationByName :: ( Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State (ScopeGraph address)) sig m , Ord address ) => address @@ -240,8 +229,7 @@ declarationByName scope name = do scopeGraph <- get maybeM (throwScopeError $ DeclarationByNameError name) (ScopeGraph.declarationByName scope name scopeGraph) -declarationsByAccessControl :: ( Member (State (ScopeGraph address)) sig - , Carrier sig m +declarationsByAccessControl :: ( Has (State (ScopeGraph address)) sig m , Ord address ) => address @@ -249,12 +237,11 @@ declarationsByAccessControl :: ( Member (State (ScopeGraph address)) sig -> Evaluator term address value m [ Info address ] declarationsByAccessControl scopeAddress accessControl = ScopeGraph.declarationsByAccessControl scopeAddress accessControl <$> get -insertImportReference :: ( Member (Resumable (BaseError (ScopeError address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentScope address)) sig - , Carrier sig m +insertImportReference :: ( Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentScope address)) sig m , Ord address ) => Reference @@ -271,8 +258,7 @@ insertImportReference ref span kind decl scopeAddress = do newScope <- maybeM (throwScopeError ImportReferenceError) (ScopeGraph.insertImportReference ref moduleInfo span kind decl currentAddress scopeGraph scope) insertScope scopeAddress newScope -insertScope :: ( Member (State (ScopeGraph address)) sig - , Carrier sig m +insertScope :: ( Has (State (ScopeGraph address)) sig m , Ord address ) => address @@ -280,9 +266,8 @@ insertScope :: ( Member (State (ScopeGraph address)) sig -> Evaluator term address value m () insertScope scopeAddress scope = modify (ScopeGraph.insertScope scopeAddress scope) -maybeLookupScopePath :: ( Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentScope address)) sig - , Carrier sig m +maybeLookupScopePath :: ( Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentScope address)) sig m , Ord address ) => Declaration @@ -291,27 +276,25 @@ maybeLookupScopePath Declaration{..} = do currentAddress <- currentScope gets (ScopeGraph.lookupScopePath unDeclaration currentAddress) -lookupScopePath :: ( Member (Resumable (BaseError (ScopeError address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentScope address)) sig - , Carrier sig m - , Ord address - ) - => Declaration - -> Evaluator term address value m (ScopeGraph.Path address) +lookupScopePath :: ( Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Ord address + ) + => Declaration + -> Evaluator term address value m (ScopeGraph.Path address) lookupScopePath decl@Declaration{..} = do currentAddress <- currentScope scopeGraph <- get maybeM (throwScopeError $ LookupPathError decl) (ScopeGraph.lookupScopePath unDeclaration currentAddress scopeGraph) -lookupDeclarationScope :: ( Member (Resumable (BaseError (ScopeError address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentScope address)) sig - , Carrier sig m +lookupDeclarationScope :: ( Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentScope address)) sig m , Ord address ) => Declaration @@ -321,21 +304,18 @@ lookupDeclarationScope decl = do currentScope' <- currentScope maybeM (throwScopeError $ LookupDeclarationScopeError decl) (ScopeGraph.pathDeclarationScope currentScope' path) -associatedScope :: (Ord address, Member (State (ScopeGraph address)) sig, Carrier sig m) => Declaration -> Evaluator term address value m (Maybe address) +associatedScope :: (Ord address, Has (State (ScopeGraph address)) sig m) => Declaration -> Evaluator term address value m (Maybe address) associatedScope decl = ScopeGraph.associatedScope decl <$> get -withScope :: ( Carrier sig m - , Member (Reader (CurrentScope address)) sig - ) +withScope :: Has (Reader (CurrentScope address)) sig m => address -> Evaluator term address value m a -> Evaluator term address value m a withScope scope = local (const (CurrentScope scope)) -throwScopeError :: ( Member (Resumable (BaseError (ScopeError address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Carrier sig m +throwScopeError :: ( Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m ) => ScopeError address resume -> Evaluator term address value m resume @@ -362,7 +342,7 @@ instance Eq1 (ScopeError address) where liftEq _ CurrentScopeError CurrentScopeError = True liftEq _ _ _ = False -alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator term address value m address +alloc :: (Has (Allocator address) sig m) => Name -> Evaluator term address value m address alloc = send . flip Alloc pure data Allocator address (m :: * -> *) k @@ -380,10 +360,10 @@ newtype AllocatorC address m a = AllocatorC { runAllocatorC :: m a } deriving (Alternative, Applicative, Functor, Monad) runScopeErrorWith :: (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) m) a + -> Evaluator term address value (With.ResumableC (BaseError (ScopeError address)) m) a -> Evaluator term address value m a -runScopeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) +runScopeErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) -runScopeError :: Evaluator term address value (ResumableC (BaseError (ScopeError address)) m) a - -> Evaluator term address value m (Either (SomeError (BaseError (ScopeError address))) a) -runScopeError = raiseHandler runResumable +runScopeError :: Evaluator term address value (Either.ResumableC (BaseError (ScopeError address)) m) a + -> Evaluator term address value m (Either (Either.SomeError (BaseError (ScopeError address))) a) +runScopeError = raiseHandler Either.runResumable diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 34e5fb7ec..6bd71a100 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -74,7 +74,8 @@ module Control.Abstract.Value import Control.Abstract.Evaluator import Control.Abstract.Heap import Control.Abstract.ScopeGraph (Allocator, CurrentScope, Declaration, ScopeGraph) -import Control.Effect.Carrier +import Control.Algebra +import Control.Carrier.Reader import Data.Abstract.BaseError import Data.Abstract.Module import Data.Abstract.Name @@ -108,7 +109,7 @@ data Comparator -- -- In the concrete domain, introductions & eliminations respectively construct & pattern match against values, while in abstract domains they respectively construct & project finite sets of discrete observations of abstract values. For example, an abstract domain modelling integers as a sign (-, 0, or +) would introduce abstract values by mapping integers to their sign and eliminate them by mapping signs back to some canonical integer, e.g. - -> -1, 0 -> 0, + -> 1. -function :: (Member (Function term address value) sig, Carrier sig m) => Name -> [Name] -> term -> address -> Evaluator term address value m value +function :: Has (Function term address value) sig m => Name -> [Name] -> term -> address -> Evaluator term address value m value function name params body scope = sendFunction (Function name params body scope pure) data BuiltIn @@ -116,16 +117,16 @@ data BuiltIn | Show deriving (Eq, Ord, Show, Generic) -builtIn :: (Member (Function term address value) sig, Carrier sig m) => address -> BuiltIn -> Evaluator term address value m value +builtIn :: Has (Function term address value) sig m => address -> BuiltIn -> Evaluator term address value m value 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 :: Has (Function term address value) 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) a -> Evaluator term address value m a +sendFunction :: Has (Function term address value) 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 :: Has (Function term address value) 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 @@ -147,15 +148,15 @@ newtype FunctionC term address value m a = FunctionC { runFunctionC :: ReaderC ( deriving (Alternative, Applicative, Functor, Monad) -- | Construct a boolean value in the abstract domain. -boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value +boolean :: Has (Boolean value) sig m => Bool -> m value boolean = send . flip Boolean pure -- | Extract a 'Bool' from a given value. -asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> m Bool +asBool :: Has (Boolean value) sig m => value -> m Bool asBool = send . flip AsBool pure -- | Eliminate boolean values. TODO: s/boolean/truthy -ifthenelse :: (Member (Boolean value) sig, Carrier sig m) => value -> m a -> m a -> m a +ifthenelse :: Has (Boolean value) sig m => value -> m a -> m a -> m a ifthenelse v t e = asBool v >>= \ c -> if c then t else e data Boolean value (m :: * -> *) k @@ -175,31 +176,30 @@ newtype BooleanC value m a = BooleanC { runBooleanC :: m a } -- | The fundamental looping primitive, built on top of 'ifthenelse'. -while :: (Member (While value) sig, Carrier sig m) +while :: Has (While value) sig m => Evaluator term address value m value -- ^ Condition -> Evaluator term address value m value -- ^ Body -> Evaluator term address value m value while cond body = send (While cond body pure) -- | Do-while loop, built on top of while. -doWhile :: (Member (While value) sig, Carrier sig m) +doWhile :: Has (While value) sig m => Evaluator term address value m value -- ^ Body -> Evaluator term address value m value -- ^ Condition -> Evaluator term address value m value doWhile body cond = body *> while cond body -- | C-style for loops. -forLoop :: ( Carrier sig m - , Member (Allocator address) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (While value) sig - , Member Fresh sig +forLoop :: ( Has (Allocator address) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (While value) sig m + , Has Fresh sig m , Ord address ) => Evaluator term address value m value -- ^ Initial statement @@ -224,7 +224,7 @@ newtype WhileC value m a = WhileC { runWhileC :: m a } deriving (Alternative, Applicative, Functor, Monad) -- | Construct an abstract unit value. -unit :: (Carrier sig m, Member (Unit value) sig) => Evaluator term address value m value +unit :: Has (Unit value) sig m => Evaluator term address value m value unit = send (Unit pure) newtype Unit value (m :: * -> *) k @@ -242,11 +242,11 @@ newtype UnitC value m a = UnitC { runUnitC :: m a } deriving (Alternative, Applicative, Functor, Monad) -- | Construct a String value in the abstract domain. -string :: (Member (String value) sig, Carrier sig m) => Text -> m value +string :: Has (String value) sig m => Text -> m value string t = send (String t pure) -- | Extract 'Text' from a given value. -asString :: (Member (String value) sig, Carrier sig m) => value -> m Text +asString :: Has (String value) sig m => value -> m Text asString v = send (AsString v pure) data String value (m :: * -> *) k @@ -266,19 +266,19 @@ runString = raiseHandler runStringC -- | Construct an abstract integral value. -integer :: (Member (Numeric value) sig, Carrier sig m) => Integer -> m value +integer :: Has (Numeric value) sig m => Integer -> m value integer t = send (Integer t pure) -- | Construct a floating-point value. -float :: (Member (Numeric value) sig, Carrier sig m) => Scientific -> m value +float :: Has (Numeric value) sig m => Scientific -> m value float t = send (Float t pure) -- | Construct a rational value. -rational :: (Member (Numeric value) sig, Carrier sig m) => Rational -> m value +rational :: Has (Numeric value) sig m => Rational -> m value rational t = send (Rational t pure) -- | Lift a unary operator over a 'Num' to a function on 'value's. -liftNumeric :: (Member (Numeric value) sig, Carrier sig m) +liftNumeric :: Has (Numeric value) sig m => (forall a . Num a => a -> a) -> value -> m value @@ -288,7 +288,7 @@ liftNumeric t v = send (LiftNumeric (NumericFunction t) v pure) -- You usually pass the same operator as both arguments, except in the cases where -- Haskell provides different functions for integral and fractional operations, such -- as division, exponentiation, and modulus. -liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m) +liftNumeric2 :: Has (Numeric value) sig m => (forall a b. Number a -> Number b -> SomeNumber) -> value -> value @@ -319,11 +319,11 @@ runNumeric = raiseHandler runNumericC -- | Cast numbers to integers -castToInteger :: (Member (Bitwise value) sig, Carrier sig m) => value -> m value +castToInteger :: Has (Bitwise value) sig m => value -> m value castToInteger t = send (CastToInteger t pure) -- | Lift a unary bitwise operator to values. This is usually 'complement'. -liftBitwise :: (Member (Bitwise value) sig, Carrier sig m) +liftBitwise :: Has (Bitwise value) sig m => (forall a . Bits a => a -> a) -> value -> m value @@ -332,14 +332,14 @@ 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, -- but it's fine, since these are only ever operating on integral values. -liftBitwise2 :: (Member (Bitwise value) sig, Carrier sig m) +liftBitwise2 :: Has (Bitwise value) sig m => (forall a . (Integral a, Bits a) => a -> a -> a) -> value -> value -> m value liftBitwise2 t v1 v2 = send (LiftBitwise2 (Bitwise2Function t) v1 v2 pure) -unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m) +unsignedRShift :: Has (Bitwise value) sig m => value -> value -> m value @@ -366,17 +366,17 @@ runBitwise = raiseHandler runBitwiseC newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } deriving (Alternative, Applicative, Functor, Monad) -object :: (Member (Object address value) sig, Carrier sig m) => address -> m value +object :: Has (Object address value) sig m => address -> m value object address = send (Object address pure) -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). -scopedEnvironment :: (Member (Object address value) sig, Carrier sig m) => value -> m (Maybe address) +scopedEnvironment :: Has (Object address value) sig m => value -> m (Maybe address) scopedEnvironment value = send (ScopedEnvironment value pure) -- | Build a class value from a name and environment. -- declaration is the new class's identifier -- address is the environment to capture -klass :: (Member (Object address value) sig, Carrier sig m) => Declaration -> address -> m value +klass :: Has (Object address value) sig m => Declaration -> address -> m value klass d a = send (Klass d a pure) data Object address value m k @@ -396,10 +396,10 @@ runObject :: Evaluator term address value (ObjectC address value m) a runObject = raiseHandler runObjectC -- | Construct an array of zero or more values. -array :: (Member (Array value) sig, Carrier sig m) => [value] -> m value +array :: Has (Array value) sig m => [value] -> m value array v = send (Array v pure) -asArray :: (Member (Array value) sig, Carrier sig m) => value -> m [value] +asArray :: Has (Array value) sig m => value -> m [value] asArray v = send (AsArray v pure) data Array value (m :: * -> *) k @@ -418,11 +418,11 @@ runArray :: Evaluator term address value (ArrayC value m) a runArray = raiseHandler runArrayC -- | Construct a hash out of pairs. -hash :: (Member (Hash value) sig, Carrier sig m) => [(value, value)] -> m value +hash :: Has (Hash value) sig m => [(value, value)] -> m value hash v = send (Hash v pure) -- | Construct a key-value pair for use in a hash. -kvPair :: (Member (Hash value) sig, Carrier sig m) => value -> value -> m value +kvPair :: Has (Hash value) sig m => value -> value -> m value kvPair v1 v2 = send (KvPair v1 v2 pure) data Hash value (m :: * -> *) k diff --git a/src/Control/Carrier/Parse/Measured.hs b/src/Control/Carrier/Parse/Measured.hs index 54a6381f6..3a384bddf 100644 --- a/src/Control/Carrier/Parse/Measured.hs +++ b/src/Control/Carrier/Parse/Measured.hs @@ -1,17 +1,17 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, TypeOperators, UndecidableInstances #-} -- | A carrier for 'Parse' effects suitable for use in production. module Control.Carrier.Parse.Measured -( -- * Parse effect - module Control.Effect.Parse - -- * Parse carrier -, ParseC(..) +( -- * Parse carrier + ParseC(..) -- * Exceptions , ParserCancelled(..) + -- * Parse effect +, module Control.Effect.Parse ) where import qualified Assigning.Assignment as Assignment +import Control.Algebra import Control.Effect.Error -import Control.Effect.Carrier import Control.Effect.Parse import Control.Effect.Reader import Control.Effect.Trace @@ -34,20 +34,19 @@ import Source.Source (Source) newtype ParseC m a = ParseC { runParse :: m a } deriving (Applicative, Functor, Monad, MonadIO) -instance ( Carrier sig m - , Member (Error SomeException) sig - , Member (Reader TaskSession) sig - , Member Telemetry sig - , Member Timeout sig - , Member Trace sig +instance ( Has (Error SomeException) sig m + , Has (Reader TaskSession) sig m + , Has Telemetry sig m + , Has Timeout sig m + , Has Trace sig m , MonadIO m ) - => Carrier (Parse :+: sig) (ParseC m) where - eff (L (Parse parser blob k)) = runParser blob parser >>= k - eff (R other) = ParseC (eff (handleCoercible other)) + => Algebra (Parse :+: sig) (ParseC m) where + alg (L (Parse parser blob k)) = runParser blob parser >>= k + alg (R other) = ParseC (alg (handleCoercible other)) -- | Parse a 'Blob' in 'IO'. -runParser :: (Member (Error SomeException) sig, Member (Reader TaskSession) sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) +runParser :: (Has (Error SomeException) sig m, Has (Reader TaskSession) sig m, Has Telemetry sig m, Has Timeout sig m, Has Trace sig m, MonadIO m) => Blob -> Parser term -> m term @@ -81,12 +80,11 @@ instance Exception ParserCancelled runAssignment :: ( Foldable term , Syntax.HasErrors term - , Member (Error SomeException) sig - , Member (Reader TaskSession) sig - , Member Telemetry sig - , Member Timeout sig - , Member Trace sig - , Carrier sig m + , Has (Error SomeException) sig m + , Has (Reader TaskSession) sig m + , Has Telemetry sig m + , Has Timeout sig m + , Has Trace sig m , MonadIO m ) => (Source -> assignment (term Assignment.Loc) -> ast -> Either (Error.Error String) (term Assignment.Loc)) @@ -137,7 +135,7 @@ runAssignment assign parser blob@Blob{..} assignment = do -- | Log an 'Error.Error' at the specified 'Level'. -logError :: (Member Telemetry sig, Carrier sig m) +logError :: Has Telemetry sig m => TaskSession -> Level -> Blob diff --git a/src/Control/Carrier/Parse/Simple.hs b/src/Control/Carrier/Parse/Simple.hs index f9a2c55c0..2c341061d 100644 --- a/src/Control/Carrier/Parse/Simple.hs +++ b/src/Control/Carrier/Parse/Simple.hs @@ -1,20 +1,20 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, TypeOperators, UndecidableInstances #-} -- | A carrier for 'Parse' effects suitable for use in the repl, tests, etc. module Control.Carrier.Parse.Simple -( -- * Parse effect - module Control.Effect.Parse - -- * Parse carrier -, ParseC(..) +( -- * Parse carrier + ParseC(..) , runParse -- * Exceptions , ParseFailure(..) + -- * Parse effect +, module Control.Effect.Parse ) where import qualified Assigning.Assignment as Assignment +import Control.Algebra +import Control.Carrier.Reader import Control.Effect.Error -import Control.Effect.Carrier import Control.Effect.Parse -import Control.Effect.Reader import Control.Exception import Control.Monad.IO.Class import Data.Blob @@ -23,23 +23,21 @@ import Parsing.Parser import Parsing.TreeSitter runParse :: Duration -> ParseC m a -> m a -runParse timeout = runReader timeout . runParseC +runParse timeout (ParseC m) = runReader timeout m -newtype ParseC m a = ParseC { runParseC :: ReaderC Duration m a } +newtype ParseC m a = ParseC (ReaderC Duration m a) deriving (Applicative, Functor, Monad, MonadIO) -instance ( Carrier sig m - , Member (Error SomeException) sig +instance ( Has (Error SomeException) sig m , MonadIO m ) - => Carrier (Parse :+: sig) (ParseC m) where - eff (L (Parse parser blob k)) = ParseC ask >>= \ timeout -> runParser timeout blob parser >>= k - eff (R other) = ParseC (send (handleCoercible other)) + => Algebra (Parse :+: sig) (ParseC m) where + alg (L (Parse parser blob k)) = ParseC ask >>= \ timeout -> runParser timeout blob parser >>= k + alg (R other) = ParseC (send (handleCoercible other)) -- | Parse a 'Blob' in 'IO'. runParser - :: ( Carrier sig m - , Member (Error SomeException) sig + :: ( Has (Error SomeException) sig m , MonadIO m ) => Duration diff --git a/src/Control/Effect/Interpose.hs b/src/Control/Effect/Interpose.hs index 3086cf293..89313fd6c 100644 --- a/src/Control/Effect/Interpose.hs +++ b/src/Control/Effect/Interpose.hs @@ -8,8 +8,9 @@ module Control.Effect.Interpose ) where import Control.Applicative -import Control.Effect.Carrier -import Control.Effect.Reader +import Control.Algebra +import Control.Carrier.Reader +import Control.Effect.Sum.Project data Interpose (eff :: (* -> *) -> * -> *) m k = forall a . Interpose (m a) (forall n x . eff n x -> m x) (a -> m k) @@ -24,7 +25,7 @@ instance HFunctor (Interpose eff) where -- The intercepted effects are not re-sent in the surrounding context; thus, the innermost nested 'interpose' listening for an effect will win, and the effect’s own handler will not get the chance to service the request. -- -- 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) +interpose :: Has (Interpose eff) sig m => m a -> (forall n x . eff n x -> m x) -> m a @@ -46,11 +47,11 @@ newtype Listener (eff :: (* -> *) -> * -> *) m = Listener (forall n x . eff n x 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 - eff (L (Interpose m h k)) = +instance (Has eff sig m, Project eff sig) => Algebra (Interpose eff :+: sig) (InterposeC eff m) where + alg (L (Interpose m h k)) = InterposeC (local (const (Just (Listener h))) (runInterposeC m)) >>= k - eff (R other) = do + alg (R other) = do listener <- InterposeC ask case (listener, prj other) of (Just listener, Just eff) -> runListener listener eff - _ -> InterposeC (eff (R (handleCoercible other))) + _ -> InterposeC (alg (R (handleCoercible other))) diff --git a/src/Control/Effect/Parse.hs b/src/Control/Effect/Parse.hs index 603a211c8..461ae27e3 100644 --- a/src/Control/Effect/Parse.hs +++ b/src/Control/Effect/Parse.hs @@ -7,9 +7,13 @@ module Control.Effect.Parse , parserForBlob , parseWith , parsePairWith + -- * Re-exports +, Algebra +, Has +, run ) where -import Control.Effect.Carrier +import Control.Algebra import Control.Effect.Error import Control.Exception (SomeException) import Data.Bitraversable @@ -28,11 +32,11 @@ instance HFunctor Parse where hmap f (Parse parser blob k) = Parse parser blob (f . k) instance Effect Parse where - handle state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k) + thread state handler (Parse parser blob k) = Parse parser blob (handler . (<$ state) . k) -- | Parse a 'Blob' with the given 'Parser'. -parse :: (Member Parse sig, Carrier sig m) +parse :: Has Parse sig m => Parser term -> Blob -> m term @@ -50,7 +54,7 @@ parserForBlob parsers = parserForLanguage parsers . blobLanguage -- | Parse a 'Blob' with one of the provided parsers, and run an action on the abstracted term. parseWith - :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) + :: (Has (Error SomeException) sig m, Has Parse sig m) => Map.Map Language (SomeParser c ann) -- ^ The set of parsers to select from. -> (forall term . c term => term ann -> m a) -- ^ A function to run on the parsed term. Note that the term is abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. -> Blob -- ^ The blob to parse. @@ -61,7 +65,7 @@ parseWith parsers with blob = case parserForBlob parsers blob of -- | Parse a 'BlobPair' with one of the provided parsers, and run an action on the abstracted term pair. parsePairWith - :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig) + :: (Has (Error SomeException) sig m, Has Parse sig m) => Map.Map Language (SomeParser c ann) -- ^ The set of parsers to select from. -> (forall term . c term => Edit (Blob, term ann) (Blob, term ann) -> m a) -- ^ A function to run on the parsed terms. Note that the terms are abstract, but constrained by @c@, allowing you to do anything @c@ allows, and requiring that all the input parsers produce terms supporting @c@. -> BlobPair -- ^ The blob pair to parse. diff --git a/src/Control/Effect/REPL.hs b/src/Control/Effect/REPL.hs index 0f4b2f1be..a606ad7c7 100644 --- a/src/Control/Effect/REPL.hs +++ b/src/Control/Effect/REPL.hs @@ -10,8 +10,8 @@ module Control.Effect.REPL import Prologue -import Control.Effect.Carrier -import Control.Effect.Reader +import Control.Algebra +import Control.Carrier.Reader import System.Console.Haskeline import qualified Data.Text as T @@ -23,10 +23,10 @@ data REPL (m :: * -> *) k instance HFunctor REPL instance Effect REPL -prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text) +prompt :: Has REPL sig m => Text -> m (Maybe Text) prompt p = send (Prompt p pure) -output :: (Member REPL sig, Carrier sig m) => Text -> m () +output :: Has REPL sig m => Text -> m () output s = send (Output s (pure ())) runREPL :: Prefs -> Settings IO -> REPLC m a -> m a @@ -35,13 +35,13 @@ runREPL prefs settings = runReader (prefs, settings) . runREPLC newtype REPLC m a = REPLC { runREPLC :: ReaderC (Prefs, Settings IO) m a } deriving (Functor, Applicative, Monad, MonadIO) -instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where - eff (L op) = do +instance (Algebra sig m, MonadIO m) => Algebra (REPL :+: sig) (REPLC m) where + alg (L op) = do args <- REPLC ask case op of Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= k Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> k - eff (R other) = REPLC (eff (R (handleCoercible other))) + alg (R other) = REPLC (alg (R (handleCoercible other))) cyan :: String diff --git a/src/Control/Effect/Sum/Project.hs b/src/Control/Effect/Sum/Project.hs new file mode 100644 index 000000000..a962eea5a --- /dev/null +++ b/src/Control/Effect/Sum/Project.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators #-} + +module Control.Effect.Sum.Project +( Project (..) +) where + +import Control.Effect.Sum + +class Member sub sup => Project (sub :: (* -> *) -> (* -> *)) sup where + prj :: sup m a -> Maybe (sub m a) + +instance Project sub sub where + prj = Just + +instance {-# OVERLAPPABLE #-} Project sub (sub :+: sup) where + prj (L f) = Just f + prj _ = Nothing + +instance {-# OVERLAPPABLE #-} Project sub sup => Project sub (sub' :+: sup) where + prj (R g) = prj g + prj _ = Nothing diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index a313921e4..868e33244 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -5,7 +5,7 @@ module Data.Abstract.Address.Hole ) where import Control.Abstract -import Control.Effect.Carrier +import Control.Algebra import Prologue data Hole context a = Partial context | Total a @@ -22,21 +22,21 @@ toMaybe (Total a) = Just a promoteA :: AllocatorC address m a -> AllocatorC (Hole context address) m a promoteA = AllocatorC . runAllocatorC -instance ( Carrier (Allocator address :+: sig) (AllocatorC address m) - , Carrier sig m +instance ( Algebra (Allocator address :+: sig) (AllocatorC address m) + , Algebra sig m , Monad m ) - => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where - eff (R other) = AllocatorC . eff . handleCoercible $ other - eff (L (Alloc name k)) = Total <$> promoteA (eff (L (Alloc name pure))) >>= k + => Algebra (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where + alg (R other) = AllocatorC . alg . handleCoercible $ other + alg (L (Alloc name k)) = Total <$> promoteA (alg (L (Alloc name pure))) >>= k promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a promoteD = DerefC . runDerefC -instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m) - => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where - eff (R other) = DerefC . eff . handleCoercible $ other - eff (L op) = case op of - DerefCell cell k -> promoteD (eff (L (DerefCell cell pure))) >>= k - AssignCell value cell k -> promoteD (eff (L (AssignCell value cell pure))) >>= k +instance (Algebra (Deref value :+: sig) (DerefC address value m), Algebra sig m) + => Algebra (Deref value :+: sig) (DerefC (Hole context address) value m) where + alg (R other) = DerefC . alg . handleCoercible $ other + alg (L op) = case op of + DerefCell cell k -> promoteD (alg (L (DerefCell cell pure))) >>= k + AssignCell value cell k -> promoteD (alg (L (AssignCell value cell pure))) >>= k diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index c3f7e0f4e..f32a8d206 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -3,11 +3,12 @@ module Data.Abstract.Address.Monovariant ( Monovariant(..) ) where +import Prologue + import Control.Abstract -import Control.Effect.Carrier +import Control.Algebra import Data.Abstract.Name import qualified Data.Set as Set -import Prologue -- | 'Monovariant' models using one address for a particular name. It tracks the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new. newtype Monovariant = Monovariant { unMonovariant :: Name } @@ -17,11 +18,11 @@ instance Show Monovariant where showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant -instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where - eff (L (Alloc name k)) = k (Monovariant name) - eff (R other) = AllocatorC . eff . handleCoercible $ other +instance Algebra sig m => Algebra (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where + alg (L (Alloc name k)) = k (Monovariant name) + alg (R other) = AllocatorC . alg . handleCoercible $ other -instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where - eff (L (DerefCell cell k)) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= k - eff (L (AssignCell value cell k)) = k (Set.insert value cell) - eff (R other) = DerefC . eff . handleCoercible $ other +instance (Ord value, Algebra sig m, Alternative m, Monad m) => Algebra (Deref value :+: sig) (DerefC Monovariant value m) where + alg (L (DerefCell cell k)) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= k + alg (L (AssignCell value cell k)) = k (Set.insert value cell) + alg (R other) = DerefC . alg . handleCoercible $ other diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index c60331b19..f92b6fa3c 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -5,7 +5,7 @@ module Data.Abstract.Address.Precise import Control.Abstract import Control.Abstract.ScopeGraph (AllocatorC(..)) -import Control.Effect.Carrier +import Control.Algebra import qualified Data.Set as Set import Prologue @@ -17,13 +17,13 @@ instance Show Precise where showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise -instance (Member Fresh sig, Carrier sig m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where - eff (R other) = AllocatorC . eff . handleCoercible $ other - eff (L (Alloc _ k)) = Precise <$> fresh >>= k +instance Has Fresh sig m => Algebra (Allocator Precise :+: sig) (AllocatorC Precise m) where + alg (R other) = AllocatorC . alg . handleCoercible $ other + alg (L (Alloc _ k)) = Precise <$> fresh >>= k -instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where - eff (R other) = DerefC . eff . handleCoercible $ other - eff (L op) = case op of +instance Algebra sig m => Algebra (Deref value :+: sig) (DerefC Precise value m) where + alg (R other) = DerefC . alg . handleCoercible $ other + alg (L op) = case op of DerefCell cell k -> k (fst <$> Set.minView cell) AssignCell value _ k -> k (Set.singleton value) diff --git a/src/Data/Abstract/BaseError.hs b/src/Data/Abstract/BaseError.hs index fc5af47fd..87db9a0c4 100644 --- a/src/Data/Abstract/BaseError.hs +++ b/src/Data/Abstract/BaseError.hs @@ -28,10 +28,9 @@ instance (Eq1 exc) => Eq1 (BaseError exc) where instance Show1 exc => Show1 (BaseError exc) where liftShowsPrec sl sp d (BaseError info span exc) = showParen (d > 10) $ showString "BaseError" . showChar ' ' . showsPrec 11 info . showChar ' ' . showsPrec 11 span . showChar ' ' . liftShowsPrec sl sp 11 exc -throwBaseError :: ( Member (Resumable (BaseError exc)) sig - , Member (Reader M.ModuleInfo) sig - , Member (Reader S.Span) sig - , Carrier sig m +throwBaseError :: ( Has (Resumable (BaseError exc)) sig m + , Has (Reader M.ModuleInfo) sig m + , Has (Reader S.Span) sig m ) => exc resume -> m resume diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 2b01af6f9..8b1301590 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -17,6 +17,15 @@ module Data.Abstract.Evaluatable , throwUnspecializedError ) where +import Prologue + +import Control.Algebra +import qualified Control.Carrier.Resumable.Either as Either +import qualified Control.Carrier.Resumable.Resume as With +import Data.Scientific (Scientific) +import Data.Semigroup.Foldable +import Source.Span (HasSpan(..)) + import Control.Abstract hiding (Load, String) import qualified Control.Abstract as Abstract import Control.Abstract.Context as X @@ -32,53 +41,47 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.ScopeGraph (Relation(..)) import Data.Abstract.AccessControls.Class as X import Data.Language -import Data.Scientific (Scientific) import Data.Semigroup.App -import Data.Semigroup.Foldable -import Data.Sum hiding (project) import Data.Term -import Prologue -import Source.Span (HasSpan(..)) -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class (Show1 constr, Foldable constr) => Evaluatable constr where eval :: ( AbstractValue term address value m , AccessControls term - , Carrier sig m , Declarations term , FreeVariables term , HasSpan term - , Member (Allocator address) sig - , Member (Bitwise value) sig - , Member (Boolean value) sig - , Member (While value) sig - , Member (Deref value) sig - , Member (State (ScopeGraph address)) sig - , Member (Error (LoopControl value)) sig - , Member (Error (Return value)) sig - , Member Fresh sig - , Member (Function term address value) sig - , Member (Modules address value) sig - , Member (Numeric value) sig - , Member (Object address value) sig - , Member (Array value) sig - , Member (Hash value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader PackageInfo) sig - , Member (Reader Span) sig - , Member (State Span) sig - , Member (Abstract.String value) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (AddressError address value))) sig - , Member (Resumable (BaseError (UnspecializedError address value))) sig - , Member (Resumable (BaseError (EvalError term address value))) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member (State (Heap address address value)) sig - , Member Trace sig - , Member (Unit value) sig + , Has (Allocator address) sig m + , Has (Bitwise value) sig m + , Has (Boolean value) sig m + , Has (While value) sig m + , Has (Deref value) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Error (LoopControl value)) sig m + , Has (Error (Return value)) sig m + , Has Fresh sig m + , Has (Function term address value) sig m + , Has (Modules address value) sig m + , Has (Numeric value) sig m + , Has (Object address value) sig m + , Has (Array value) sig m + , Has (Hash value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader PackageInfo) sig m + , Has (Reader Span) sig m + , Has (State Span) sig m + , Has (Abstract.String value) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (AddressError address value))) sig m + , Has (Resumable (BaseError (UnspecializedError address value))) sig m + , Has (Resumable (BaseError (EvalError term address value))) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has (State (Heap address address value)) sig m + , Has Trace sig m + , Has (Unit value) sig m , Ord address , Show address ) @@ -90,19 +93,18 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where throwUnspecializedError $ UnspecializedError ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "") ref :: ( AbstractValue term address value m - , Carrier sig m , Declarations term - , Member (Object address value) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (EvalError term address value))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (UnspecializedError address value))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig + , Has (Object address value) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (EvalError term address value))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (UnspecializedError address value))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m , Ord address ) => (term -> Evaluator term address value m value) @@ -112,7 +114,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where throwUnspecializedError $ RefUnspecializedError ("ref unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "") -traceResolve :: (Show a, Show b, Member Trace sig, Carrier sig m) => a -> b -> Evaluator term address value m () +traceResolve :: (Show a, Show b, Has Trace sig m) => a -> b -> Evaluator term address value m () traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) @@ -120,24 +122,23 @@ traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) class HasPrelude (language :: Language) where definePrelude :: ( AbstractValue term address value m - , Carrier sig m , HasCallStack - , Member (Allocator address) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Deref value) sig - , Member Fresh sig - , Member (Function term address value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (AddressError address value))) sig - , Member (State (Heap address address value)) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member Trace sig - , Member (Unit value) sig - , Member (Object address value) sig + , Has (Allocator address) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Deref value) sig m + , Has Fresh sig m + , Has (Function term address value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (AddressError address value))) sig m + , Has (State (Heap address address value)) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has Trace sig m + , Has (Unit value) sig m + , Has (Object address value) sig m , Ord address , Show address ) @@ -175,17 +176,16 @@ instance HasPrelude 'JavaScript where defineSelf defineNamespace (Declaration (X.name "console")) $ defineBuiltIn (Declaration $ X.name "log") Default Public Print -defineSelf :: ( Carrier sig m - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Deref value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State (Heap address address value)) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Object address value) sig +defineSelf :: ( Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Deref value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State (Heap address address value)) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Object address value) sig m , Ord address ) => Evaluator term address value m () @@ -213,10 +213,9 @@ data EvalError term address value return where ReferenceError :: value -> term -> EvalError term address value (Slot address) ScopedEnvError :: value -> EvalError term address value address -throwNoNameError :: ( Carrier sig m - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (EvalError term address value))) sig +throwNoNameError :: ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (EvalError term address value))) sig m ) => term -> Evaluator term address value m Name @@ -240,19 +239,18 @@ instance (Eq term, Eq value) => Eq1 (EvalError term address value) where instance (Show term, Show value) => Show1 (EvalError term address value) where liftShowsPrec _ _ = showsPrec -runEvalError :: Evaluator term address value (ResumableC (BaseError (EvalError term address value)) m) a - -> Evaluator term address value m (Either (SomeError (BaseError (EvalError term address value))) a) -runEvalError = raiseHandler runResumable +runEvalError :: Evaluator term address value (Either.ResumableC (BaseError (EvalError term address value)) m) a + -> Evaluator term address value m (Either (Either.SomeError (BaseError (EvalError term address value))) a) +runEvalError = raiseHandler Either.runResumable runEvalErrorWith :: (forall resume . (BaseError (EvalError term address value)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) m) a + -> Evaluator term address value (With.ResumableC (BaseError (EvalError term address value)) m) a -> Evaluator term address value m a -runEvalErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) +runEvalErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) -throwEvalError :: ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (EvalError term address value))) sig - , Carrier sig m +throwEvalError :: ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (EvalError term address value))) sig m ) => EvalError term address value resume -> Evaluator term address value m resume @@ -275,20 +273,19 @@ instance Eq1 (UnspecializedError address value) where instance Show1 (UnspecializedError address value) where liftShowsPrec _ _ = showsPrec -runUnspecialized :: Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) m) a - -> Evaluator term address value m (Either (SomeError (BaseError (UnspecializedError address value))) a) -runUnspecialized = raiseHandler runResumable +runUnspecialized :: Evaluator term address value (Either.ResumableC (BaseError (UnspecializedError address value)) m) a + -> Evaluator term address value m (Either (Either.SomeError (BaseError (UnspecializedError address value))) a) +runUnspecialized = raiseHandler Either.runResumable runUnspecializedWith :: (forall resume . BaseError (UnspecializedError address value) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) m) a + -> Evaluator term address value (With.ResumableC (BaseError (UnspecializedError address value)) m) a -> Evaluator term address value m a -runUnspecializedWith f = raiseHandler $ runResumableWith (runEvaluator . f) +runUnspecializedWith f = raiseHandler $ With.runResumable (runEvaluator . f) -throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError address value))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Carrier sig m +throwUnspecializedError :: ( Has (Resumable (BaseError (UnspecializedError address value))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m ) => UnspecializedError address value resume -> Evaluator term address value m resume diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 7af31fe90..5ec366642 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -23,7 +23,7 @@ data Name deriving (Eq, Ord) -- | Generate a fresh (unused) name for use in synthesized variables/closures/etc. -gensym :: (Member Fresh sig, Carrier sig m) => m Name +gensym :: Has Fresh sig m => m Name gensym = I <$> fresh -- | Construct a 'Name' from a 'Text'. diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index d45b81a79..12c7e7f95 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -7,7 +7,7 @@ module Data.Abstract.Value.Abstract ) where import Control.Abstract as Abstract -import Control.Effect.Carrier +import Control.Algebra import Data.Abstract.BaseError import Data.Abstract.Evaluatable import qualified Data.Map.Strict as Map @@ -17,29 +17,29 @@ data Abstract = Abstract deriving (Eq, Ord, Show) -instance ( Member (Allocator address) sig - , Member (Deref Abstract) sig - , Member (Error (Return Abstract)) sig - , Member Fresh sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State Span) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (EvalError term address Abstract))) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (AddressError address Abstract))) sig - , Member (State (Heap address address Abstract)) sig +instance ( Has (Allocator address) sig m + , Has (Deref Abstract) sig m + , Has (Error (Return Abstract)) sig m + , Has Fresh sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State Span) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (EvalError term address Abstract))) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (AddressError address Abstract))) sig m + , Has (State (Heap address address Abstract)) sig m , Declarations term , Ord address , Show address - , Carrier sig m + , Algebra sig m ) - => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract m) where - eff (R other) = FunctionC . eff . R . handleCoercible $ other - eff (L op) = runEvaluator $ do + => Algebra (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract m) where + alg (R other) = FunctionC . alg . R . handleCoercible $ other + alg (L op) = runEvaluator $ do eval <- Evaluator . FunctionC $ ask case op of Function _ params body scope k -> do @@ -58,72 +58,72 @@ instance ( Member (Allocator address) sig Call _ _ k -> Evaluator (k Abstract) -instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where - eff (L (Boolean _ k)) = k Abstract - eff (L (AsBool _ k)) = k True <|> k False - eff (R other) = BooleanC . eff . handleCoercible $ other +instance (Algebra sig m, Alternative m) => Algebra (Boolean Abstract :+: sig) (BooleanC Abstract m) where + alg (L (Boolean _ k)) = k Abstract + alg (L (AsBool _ k)) = k True <|> k False + alg (R other) = BooleanC . alg . handleCoercible $ other -instance ( Member (Abstract.Boolean Abstract) sig - , Carrier sig m +instance ( Has (Abstract.Boolean Abstract) sig m + , Algebra sig m , Alternative m ) - => Carrier (While Abstract :+: sig) (WhileC Abstract m) where - eff (R other) = WhileC . eff . handleCoercible $ other - eff (L (Abstract.While cond body k)) = do + => Algebra (While Abstract :+: sig) (WhileC Abstract m) where + alg (R other) = WhileC . alg . handleCoercible $ other + alg (L (Abstract.While cond body k)) = do cond' <- cond ifthenelse cond' (body *> empty) (k Abstract) -instance Carrier sig m - => Carrier (Unit Abstract :+: sig) (UnitC Abstract m) where - eff (R other) = UnitC . eff . handleCoercible $ other - eff (L (Abstract.Unit k)) = k Abstract +instance Algebra sig m + => Algebra (Unit Abstract :+: sig) (UnitC Abstract m) where + alg (R other) = UnitC . alg . handleCoercible $ other + alg (L (Abstract.Unit k)) = k Abstract -instance Carrier sig m - => Carrier (Abstract.String Abstract :+: sig) (StringC Abstract m) where - eff (R other) = StringC . eff . handleCoercible $ other - eff (L op) = case op of +instance Algebra sig m + => Algebra (Abstract.String Abstract :+: sig) (StringC Abstract m) where + alg (R other) = StringC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.String _ k -> k Abstract AsString _ k -> k "" -instance Carrier sig m - => Carrier (Numeric Abstract :+: sig) (NumericC Abstract m) where - eff (R other) = NumericC . eff . handleCoercible $ other - eff (L op) = case op of +instance Algebra sig m + => Algebra (Numeric Abstract :+: sig) (NumericC Abstract m) where + alg (R other) = NumericC . alg . handleCoercible $ other + alg (L op) = case op of Integer _ k -> k Abstract Float _ k -> k Abstract Rational _ k -> k Abstract LiftNumeric _ _ k -> k Abstract LiftNumeric2 _ _ _ k -> k Abstract -instance Carrier sig m - => Carrier (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where - eff (R other) = BitwiseC . eff . handleCoercible $ other - eff (L op) = case op of +instance Algebra sig m + => Algebra (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where + alg (R other) = BitwiseC . alg . handleCoercible $ other + alg (L op) = case op of CastToInteger _ k -> k Abstract LiftBitwise _ _ k -> k Abstract LiftBitwise2 _ _ _ k -> k Abstract UnsignedRShift _ _ k -> k Abstract -instance Carrier sig m - => Carrier (Object address Abstract :+: sig) (ObjectC address Abstract m) where - eff (R other) = ObjectC . eff . handleCoercible $ other - eff (L op) = case op of +instance Algebra sig m + => Algebra (Object address Abstract :+: sig) (ObjectC address Abstract m) where + alg (R other) = ObjectC . alg . handleCoercible $ other + alg (L op) = case op of Object _ k -> k Abstract ScopedEnvironment _ k -> k Nothing Klass _ _ k -> k Abstract -instance Carrier sig m - => Carrier (Array Abstract :+: sig) (ArrayC Abstract m) where - eff (R other) = ArrayC . eff . handleCoercible $ other - eff (L op) = case op of +instance Algebra sig m + => Algebra (Array Abstract :+: sig) (ArrayC Abstract m) where + alg (R other) = ArrayC . alg . handleCoercible $ other + alg (L op) = case op of Array _ k -> k Abstract AsArray _ k -> k [] -instance Carrier sig m - => Carrier (Hash Abstract :+: sig) (HashC Abstract m) where - eff (R other) = HashC . eff . handleCoercible $ other - eff (L op) = case op of +instance Algebra sig m + => Algebra (Hash Abstract :+: sig) (HashC Abstract m) where + alg (R other) = HashC . alg . handleCoercible $ other + alg (L op) = case op of Hash _ k -> k Abstract KvPair _ _ k -> k Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 9dc1e02c5..887b4cb6c 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -6,25 +6,29 @@ module Data.Abstract.Value.Concrete , runValueErrorWith ) where +import Prologue + +import Control.Carrier.Resumable.Either (SomeError) +import qualified Control.Carrier.Resumable.Either as Either +import qualified Control.Carrier.Resumable.Resume as With +import Data.List (genericIndex, genericLength) +import qualified Data.Map.Strict as Map +import Data.Scientific (Scientific, coefficient, normalize) +import Data.Scientific.Exts +import Data.Text (pack) + import Control.Abstract.ScopeGraph (Allocator, ScopeError) import Control.Abstract.Heap (scopeLookup) 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.Algebra import Control.Effect.Interpose import Data.Abstract.BaseError import Data.Abstract.Evaluatable (UnspecializedError(..), EvalError(..), Declarations) import Data.Abstract.FreeVariables import Data.Abstract.Name import qualified Data.Abstract.Number as Number -import Data.Bits -import Data.List (genericIndex, genericLength) -import Data.Scientific (Scientific, coefficient, normalize) -import Data.Scientific.Exts -import Data.Text (pack) -import Data.Word -import Prologue -import qualified Data.Map.Strict as Map + data Value term address -- TODO: Split Closure up into a separate data type. Scope Frame @@ -52,33 +56,33 @@ instance ValueRoots address (Value term address) where instance ( FreeVariables term - , Member (Allocator address) sig - , Member (Deref (Value term address)) sig - , Member Fresh sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader PackageInfo) sig - , Member (Reader Span) sig - , Member (State Span) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (AddressError address (Value term address)))) sig - , Member (Resumable (BaseError (EvalError term address (Value term address)))) sig - , Member (Resumable (BaseError (ValueError term address))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (State (Heap address address (Value term address))) sig - , Member (Error (Return (Value term address))) sig + , Has (Allocator address) sig m + , Has (Deref (Value term address)) sig m + , Has Fresh sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader PackageInfo) sig m + , Has (Reader Span) sig m + , Has (State Span) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (AddressError address (Value term address)))) sig m + , Has (Resumable (BaseError (EvalError term address (Value term address)))) sig m + , Has (Resumable (BaseError (ValueError term address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (State (Heap address address (Value term address))) sig m + , Has (Error (Return (Value term address))) sig m , Declarations term - , Member Trace sig + , Has Trace sig m , Ord address - , Carrier sig m + , Algebra sig m , Show address , Show term ) - => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) m) where - eff (R other) = FunctionC . eff . R . handleCoercible $ other - eff (L op) = runEvaluator $ do + => Algebra (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) m) where + alg (R other) = FunctionC . alg . R . handleCoercible $ other + alg (L op) = runEvaluator $ do eval <- Evaluator . FunctionC $ ask let closure maybeName params body scope = do packageInfo <- currentPackage @@ -119,27 +123,27 @@ instance ( FreeVariables term _ -> throwValueError (CallError op) Evaluator (k boxed) -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (ValueError term address))) sig m + , Algebra sig m , Monad m ) - => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where - eff (R other) = BooleanC . eff . handleCoercible $ other - eff (L op) = case op of + => Algebra (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where + alg (R other) = BooleanC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.Boolean b k -> k $! Boolean b Abstract.AsBool (Boolean b) k -> k b Abstract.AsBool other k -> throwBaseError (BoolError other) >>= k -instance ( Carrier sig m - , Member (Abstract.Boolean (Value term address)) sig - , Member (Error (LoopControl (Value term address))) sig - , Member (Interpose (Resumable (BaseError (UnspecializedError address (Value term address))))) sig +instance ( Algebra sig m + , Has (Abstract.Boolean (Value term address)) sig m + , Has (Error (LoopControl (Value term address))) sig m + , Has (Interpose (Resumable (BaseError (UnspecializedError address (Value term address))))) sig m ) - => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where - eff (R other) = WhileC . eff . handleCoercible $ other - eff (L (Abstract.While cond body k)) = do + => Algebra (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where + alg (R other) = WhileC . alg . handleCoercible $ other + alg (L (Abstract.While cond body k)) = do let loop x = catchError x $ \case Break value -> pure value @@ -194,33 +198,33 @@ instance ( Carrier sig m -- Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) >>= k -instance Carrier sig m - => Carrier (Abstract.Unit (Value term address) :+: sig) (UnitC (Value term address) m) where - eff (R other) = UnitC . eff . handleCoercible $ other - eff (L (Abstract.Unit k )) = k Unit +instance Algebra sig m + => Algebra (Abstract.Unit (Value term address) :+: sig) (UnitC (Value term address) m) where + alg (R other) = UnitC . alg . handleCoercible $ other + alg (L (Abstract.Unit k )) = k Unit -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (ValueError term address))) sig m + , Algebra sig m , Monad m ) - => Carrier (Abstract.String (Value term address) :+: sig) (StringC (Value term address) m) where - eff (R other) = StringC . eff . handleCoercible $ other - eff (L op) = case op of + => Algebra (Abstract.String (Value term address) :+: sig) (StringC (Value term address) m) where + alg (R other) = StringC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.String t k -> k (String t) Abstract.AsString (String t) k -> k t Abstract.AsString other k -> throwBaseError (StringError other) >>= k -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (ValueError term address))) sig m + , Algebra sig m , Monad m ) - => Carrier (Abstract.Numeric (Value term address) :+: sig) (NumericC (Value term address) m) where - eff (R other) = NumericC . eff . handleCoercible $ other - eff (L op) = case op of + => Algebra (Abstract.Numeric (Value term address) :+: sig) (NumericC (Value term address) m) where + alg (R other) = NumericC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.Integer t k -> k (Integer (Number.Integer t)) Abstract.Float t k -> k (Float (Number.Decimal t)) Abstract.Rational t k -> k (Rational (Number.Ratio t)) @@ -242,10 +246,9 @@ instance ( Member (Reader ModuleInfo) sig _ -> throwBaseError (Numeric2Error left right) -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor -specialize :: ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig - , Carrier sig m +specialize :: ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (ValueError term address))) sig m ) => Either ArithException Number.SomeNumber -> m (Value term address) @@ -255,15 +258,15 @@ specialize (Right (Number.SomeNumber (Number.Decimal t))) = pure (Float (Number. specialize (Right (Number.SomeNumber (Number.Ratio t))) = pure (Rational (Number.Ratio t)) -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (ValueError term address))) sig m + , Algebra sig m , Monad m ) - => Carrier (Abstract.Bitwise (Value term address) :+: sig) (BitwiseC (Value term address) m) where - eff (R other) = BitwiseC . eff . handleCoercible $ other - eff (L op) = case op of + => Algebra (Abstract.Bitwise (Value term address) :+: sig) (BitwiseC (Value term address) m) where + alg (R other) = BitwiseC . alg . handleCoercible $ other + alg (L op) = case op of 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 @@ -278,9 +281,9 @@ ourShift :: Word64 -> Int -> Integer ourShift a b = toInteger (shiftR a b) -instance Carrier sig m => Carrier (Abstract.Object address (Value term address) :+: sig) (ObjectC address (Value term address) m) where - eff (R other) = ObjectC . eff . handleCoercible $ other - eff (L op) = case op of +instance Algebra sig m => Algebra (Abstract.Object address (Value term address) :+: sig) (ObjectC address (Value term address) m) where + alg (R other) = ObjectC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.Object address k -> k (Object address) Abstract.ScopedEnvironment (Object address) k -> k (Just address) Abstract.ScopedEnvironment (Class _ _ address) k -> k (Just address) @@ -288,22 +291,22 @@ instance Carrier sig m => Carrier (Abstract.Object address (Value term address) Abstract.ScopedEnvironment _ k -> k Nothing Abstract.Klass n frame k -> k (Class n mempty frame) -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (ValueError term address))) sig m + , Algebra sig m , Monad m ) - => Carrier (Abstract.Array (Value term address) :+: sig) (ArrayC (Value term address) m) where - eff (R other) = ArrayC . eff . handleCoercible $ other - eff (L op) = case op of + => Algebra (Abstract.Array (Value term address) :+: sig) (ArrayC (Value term address) m) where + alg (R other) = ArrayC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.Array t k -> k (Array t) Abstract.AsArray (Array addresses) k -> k addresses Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= k -instance ( Carrier sig m ) => Carrier (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where - eff (R other) = HashC . eff . handleCoercible $ other - eff (L op) = case op of +instance ( Algebra sig m ) => Algebra (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where + alg (R other) = HashC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.Hash t k -> k ((Hash . map (uncurry KVPair)) t) Abstract.KvPair t v k -> k (KVPair t v) @@ -315,13 +318,13 @@ instance (Show address, Show term) => AbstractIntro (Value term address) where null = Null -- | Construct a 'Value' wrapping the value arguments (if any). -instance ( Member (Abstract.Boolean (Value term address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (ValueError term address))) sig +instance ( Has (Abstract.Boolean (Value term address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (ValueError term address))) sig m , Show address , Show term - , Carrier sig m + , Algebra sig m ) => AbstractValue term address (Value term address) m where asPair val @@ -399,19 +402,18 @@ deriving instance (Show address, Show term) => Show (ValueError term address res instance (Show address, Show term) => Show1 (ValueError term address) where liftShowsPrec _ _ = showsPrec -runValueError :: Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) m) a +runValueError :: Evaluator term address (Value term address) (Either.ResumableC (BaseError (ValueError term address)) m) a -> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a) -runValueError = Evaluator . runResumable . runEvaluator +runValueError = Evaluator . Either.runResumable . runEvaluator runValueErrorWith :: (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume) - -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) m) a + -> Evaluator term address (Value term address) (With.ResumableC (BaseError (ValueError term address)) m) a -> Evaluator term address (Value term address) m a -runValueErrorWith f = Evaluator . runResumableWith (runEvaluator . f) . runEvaluator +runValueErrorWith f = Evaluator . With.runResumable (runEvaluator . f) . runEvaluator -throwValueError :: ( Member (Resumable (BaseError (ValueError term address))) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Carrier sig m +throwValueError :: ( Has (Resumable (BaseError (ValueError term address))) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m ) => ValueError term address resume -> Evaluator term address (Value term address) m resume diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index c1eb2a49f..3f4dc6d4d 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -11,14 +11,20 @@ module Data.Abstract.Value.Type , runWhile ) where +import Prologue hiding (TypeError) + +import Control.Algebra +import Control.Carrier.State.Strict +import qualified Control.Carrier.Resumable.Resume as With +import Control.Carrier.Resumable.Either (SomeError) +import qualified Control.Carrier.Resumable.Either as Either +import qualified Data.Map as Map + 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 Data.Abstract.BaseError import Data.Semigroup.Foldable (foldMap1) -import qualified Data.Map as Map -import Prologue hiding (TypeError) import Data.Abstract.Evaluatable type TName = Int @@ -86,39 +92,38 @@ instance Ord1 TypeError where instance Show1 TypeError where liftShowsPrec _ _ = showsPrec -runTypeError :: Evaluator term address value (ResumableC (BaseError TypeError) m) a +runTypeError :: Evaluator term address value (Either.ResumableC (BaseError TypeError) m) a -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a) -runTypeError = raiseHandler runResumable +runTypeError = raiseHandler Either.runResumable runTypeErrorWith :: (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError TypeError) m) a + -> Evaluator term address value (With.ResumableC (BaseError TypeError) m) a -> Evaluator term address value m a -runTypeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) +runTypeErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) -throwTypeError :: ( Member (Resumable (BaseError TypeError)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Carrier sig m +throwTypeError :: ( Has (Resumable (BaseError TypeError)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m ) => TypeError resume -> m resume throwTypeError = throwBaseError -runTypeMap :: Carrier sig m +runTypeMap :: Algebra sig m => Evaluator term address Type (StateC TypeMap m) a -> Evaluator term address Type m a runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap -runTypes :: Carrier sig m - => Evaluator term address Type (ResumableC (BaseError TypeError) +runTypes :: Algebra sig m + => Evaluator term address Type (Either.ResumableC (BaseError TypeError) (StateC TypeMap m)) a -> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a) runTypes = runTypeMap . runTypeError -runTypesWith :: Carrier sig m +runTypesWith :: Algebra sig m => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap m) resume) - -> Evaluator term address Type (ResumableWithC (BaseError TypeError) + -> Evaluator term address Type (With.ResumableC (BaseError TypeError) (StateC TypeMap m)) a -> Evaluator term address Type m a @@ -130,17 +135,13 @@ newtype TypeMap = TypeMap { unTypeMap :: Map.Map TName Type } emptyTypeMap :: TypeMap emptyTypeMap = TypeMap Map.empty -modifyTypeMap :: ( Member (State TypeMap) sig - , Carrier sig m - ) +modifyTypeMap :: Has (State TypeMap) sig m => (Map.Map TName Type -> Map.Map TName Type) -> m () modifyTypeMap f = modify (TypeMap . f . unTypeMap) -- | Prunes substituted type variables -prune :: ( Member (State TypeMap) sig - , Carrier sig m - ) +prune :: Has (State TypeMap) sig m => Type -> m Type prune (Var id) = gets (Map.lookup id . unTypeMap) >>= \case @@ -153,9 +154,7 @@ prune ty = pure ty -- | Checks whether a type variable name occurs within another type. This -- function is used in 'substitute' to prevent unification of infinite types -occur :: ( Member (State TypeMap) sig - , Carrier sig m - ) +occur :: Has (State TypeMap) sig m => TName -> Type -> m Bool @@ -181,11 +180,10 @@ occur id = prune >=> \case eitherM f (a, b) = (||) <$> f a <*> f b -- | Substitutes a type variable name for another type -substitute :: ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m +substitute :: ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (State TypeMap) sig m ) => TName -> Type @@ -199,11 +197,10 @@ substitute id ty = do pure ty -- | Unify two 'Type's. -unify :: ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m +unify :: ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (State TypeMap) sig m ) => Type -> Type @@ -229,31 +226,31 @@ instance Ord address => ValueRoots address Type where valueRoots _ = mempty -instance ( Member (Allocator address) sig - , Member (Deref Type) sig - , Member (Error (Return Type)) sig - , Member Fresh sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (State Span) sig - , Member (Resumable (BaseError (EvalError term address Type))) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (Resumable (BaseError (AddressError address Type))) sig - , Member (State (Heap address address Type)) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (State TypeMap) sig +instance ( Has (Allocator address) sig m + , Has (Deref Type) sig m + , Has (Error (Return Type)) sig m + , Has Fresh sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (State Span) sig m + , Has (Resumable (BaseError (EvalError term address Type))) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (Resumable (BaseError (AddressError address Type))) sig m + , Has (State (Heap address address Type)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (State TypeMap) sig m , Declarations term , Ord address , Show address - , Carrier sig m + , Algebra sig m ) - => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type m) where - eff (R other) = FunctionC (eff (R (handleCoercible other))) - eff (L op) = runEvaluator $ do + => Algebra (Abstract.Function term address Type :+: sig) (FunctionC term address Type m) where + alg (R other) = FunctionC (alg (R (handleCoercible other))) + alg (L op) = runEvaluator $ do eval <- Evaluator . FunctionC $ ask case op of Abstract.Function _ params body scope k -> do @@ -285,58 +282,58 @@ instance ( Member (Allocator address) sig -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (State TypeMap) sig m + , Algebra sig m , Alternative m ) - => Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where - eff (R other) = BooleanC . eff . handleCoercible $ other - eff (L (Abstract.Boolean _ k)) = k Bool - eff (L (Abstract.AsBool t k)) = unify t Bool *> (k True <|> k False) + => Algebra (Abstract.Boolean Type :+: sig) (BooleanC Type m) where + alg (R other) = BooleanC . alg . handleCoercible $ other + alg (L (Abstract.Boolean _ k)) = k Bool + alg (L (Abstract.AsBool t k)) = unify t Bool *> (k True <|> k False) -instance ( Member (Abstract.Boolean Type) sig - , Carrier sig m +instance ( Has (Abstract.Boolean Type) sig m + , Algebra sig m , Alternative m ) - => Carrier (Abstract.While Type :+: sig) (WhileC Type m) where - eff (R other) = WhileC . eff . handleCoercible $ other - eff (L (Abstract.While cond body k)) = do + => Algebra (Abstract.While Type :+: sig) (WhileC Type m) where + alg (R other) = WhileC . alg . handleCoercible $ other + alg (L (Abstract.While cond body k)) = do cond' <- cond ifthenelse cond' (body *> empty) (k Unit) -instance Carrier sig m - => Carrier (Abstract.Unit Type :+: sig) (UnitC Type m) where - eff (R other) = UnitC . eff . handleCoercible $ other - eff (L (Abstract.Unit k)) = k Unit +instance Algebra sig m + => Algebra (Abstract.Unit Type :+: sig) (UnitC Type m) where + alg (R other) = UnitC . alg . handleCoercible $ other + alg (L (Abstract.Unit k)) = k Unit -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (State TypeMap) sig m + , Algebra sig m , Alternative m ) - => Carrier (Abstract.String Type :+: sig) (StringC Type m) where - eff (R other) = StringC . eff . handleCoercible $ other - eff (L (Abstract.String _ k)) = k String - eff (L (Abstract.AsString t k)) = unify t String *> k "" + => Algebra (Abstract.String Type :+: sig) (StringC Type m) where + alg (R other) = StringC . alg . handleCoercible $ other + alg (L (Abstract.String _ k)) = k String + alg (L (Abstract.AsString t k)) = unify t String *> k "" -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (State TypeMap) sig m + , Algebra sig m , Monad m ) - => Carrier (Abstract.Numeric Type :+: sig) (NumericC Type m) where - eff (R other) = NumericC . eff . handleCoercible $ other - eff (L op) = case op of + => Algebra (Abstract.Numeric Type :+: sig) (NumericC Type m) where + alg (R other) = NumericC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.Integer _ k -> k Int Abstract.Float _ k -> k Float Abstract.Rational _ k -> k Rational @@ -346,50 +343,50 @@ instance ( Member (Reader ModuleInfo) sig (Int, Float) -> k Float _ -> unify left right >>= k -instance ( Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m +instance ( Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (State TypeMap) sig m + , Algebra sig m , Monad m ) - => Carrier (Abstract.Bitwise Type :+: sig) (BitwiseC Type m) where - eff (R other) = BitwiseC . eff . handleCoercible $ other - eff (L op) = case op of + => Algebra (Abstract.Bitwise Type :+: sig) (BitwiseC Type m) where + alg (R other) = BitwiseC . alg . handleCoercible $ other + alg (L op) = case op of CastToInteger t k -> unify t (Int :+ Float :+ Rational) *> k Int LiftBitwise _ t k -> unify t Int >>= k LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= k UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= k -instance ( Carrier sig m ) => Carrier (Abstract.Object address Type :+: sig) (ObjectC address Type m) where - eff (R other) = ObjectC . eff . handleCoercible $ other - eff (L op) = case op of +instance ( Algebra sig m ) => Algebra (Abstract.Object address Type :+: sig) (ObjectC address Type m) where + alg (R other) = ObjectC . alg . handleCoercible $ other + alg (L op) = case op of Abstract.Object _ k -> k Object Abstract.ScopedEnvironment _ k -> k Nothing Abstract.Klass _ _ k -> k Object -instance ( Member Fresh sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m +instance ( Has Fresh sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (State TypeMap) sig m + , Algebra sig m , Monad m ) - => Carrier (Abstract.Array Type :+: sig) (ArrayC Type m) where - eff (R other) = ArrayC . eff . handleCoercible $ other - eff (L (Abstract.Array fieldTypes k)) = do + => Algebra (Abstract.Array Type :+: sig) (ArrayC Type m) where + alg (R other) = ArrayC . alg . handleCoercible $ other + alg (L (Abstract.Array fieldTypes k)) = do var <- fresh fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes k (Array fieldType) - eff (L (Abstract.AsArray t k)) = do + alg (L (Abstract.AsArray t k)) = do field <- fresh unify t (Array (Var field)) >> k mempty -instance ( Carrier sig m ) => Carrier (Abstract.Hash Type :+: sig) (HashC Type m) where - eff (R other) = HashC . eff . handleCoercible $ other - eff (L (Abstract.Hash t k)) = k (Hash t) - eff (L (Abstract.KvPair t1 t2 k)) = k (t1 :* t2) +instance ( Algebra sig m ) => Algebra (Abstract.Hash Type :+: sig) (HashC Type m) where + alg (R other) = HashC . alg . handleCoercible $ other + alg (L (Abstract.Hash t k)) = k (Hash t) + alg (L (Abstract.KvPair t1 t2 k)) = k (t1 :* t2) instance AbstractHole Type where @@ -399,12 +396,12 @@ instance AbstractIntro Type where null = Null -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance ( Member Fresh sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError TypeError)) sig - , Member (State TypeMap) sig - , Carrier sig m +instance ( Has Fresh sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError TypeError)) sig m + , Has (State TypeMap) sig m + , Algebra sig m ) => AbstractValue term address Type m where tuple fields = pure $ zeroOrMoreProduct fields diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 852f6ae76..b2df25015 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -94,7 +94,7 @@ decodeBlobs = fmap blobs <$> eitherDecode newtype NoLanguageForBlob = NoLanguageForBlob FilePath deriving (Eq, Exception, Ord, Show) -noLanguageForBlob :: (Member (Error SomeException) sig, Carrier sig m) => FilePath -> m a +noLanguageForBlob :: Has (Error SomeException) sig m => FilePath -> m a noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath)) -- | Represents a blobs suitable for diffing which can be either a blob to diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs index 9366a784d..b219cc468 100644 --- a/src/Data/Graph.hs +++ b/src/Data/Graph.hs @@ -20,7 +20,7 @@ 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.State +import Control.Carrier.State.Strict import Control.Lens (view) import Data.Aeson import qualified Data.Set as Set @@ -50,7 +50,7 @@ topologicalSort = go . Class.toAdjacencyMap . G.transpose . unGraph . traverse_ visit . A.vertexList $ graph - where visit :: (Member (State (Visited v)) sig, Carrier sig m) => v -> m () + where visit :: Has (State (Visited v)) sig m => v -> m () visit v = do isMarked <- Set.member v . visitedVertices <$> get if isMarked then diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index e2f55f24c..d0e18e619 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -39,12 +39,11 @@ instance Evaluatable Function where v <- function name params functionBody associatedScope v <$ assign addr v -declareFunction :: ( Carrier sig m - , Member (State (ScopeGraph address)) sig - , Member (Allocator address) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member Fresh sig +declareFunction :: ( Has (State (ScopeGraph address)) sig m + , Has (Allocator address) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has Fresh sig m , Ord address ) => Maybe Name diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 2dfd33241..bca174ccd 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -4,8 +4,8 @@ module Data.Syntax.Expression (module Data.Syntax.Expression) where import Prelude hiding (null) import Prologue hiding (index, null) -import Control.Abstract hiding (Bitwise (..), Call, Member) -import Data.Abstract.Evaluatable as Abstract hiding (Member) +import Control.Abstract hiding (Bitwise (..), Call) +import Data.Abstract.Evaluatable as Abstract import Data.Abstract.Name as Name import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv) import Data.Fixed diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index e63f2ad1e..f8ce1bb0d 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -3,8 +3,8 @@ module Data.Syntax.Statement (module Data.Syntax.Statement) where import Prologue -import Control.Abstract hiding (Break, Continue, Return, While) -import Data.Abstract.Evaluatable as Abstract +import Control.Abstract hiding (Break, Catch, Continue, Return, Throw, While) +import Data.Abstract.Evaluatable as Abstract hiding (Catch, Throw) import Data.Aeson (ToJSON1 (..)) import Data.JSON.Fields import qualified Data.Abstract.ScopeGraph as ScopeGraph diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index 8d2b98607..9bd5f7011 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -14,7 +14,7 @@ module Diffing.Algorithm , algorithmForTerms ) where -import Control.Effect.Carrier hiding ((:+:)) +import Control.Algebra hiding ((:+:)) import Control.Effect.NonDet import qualified Data.Diff as Diff import qualified Data.Edit as Edit @@ -45,53 +45,53 @@ instance Effect (Diff term1 term2 diff) newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a } deriving (Applicative, Alternative, Functor, Monad) -instance Carrier sig m => Carrier sig (Algorithm term1 term2 diff m) where - eff = Algorithm . eff . handleCoercible +instance Algebra sig m => Algebra sig (Algorithm term1 term2 diff m) where + alg = Algorithm . alg . handleCoercible -- DSL -- | Diff two terms without specifying the algorithm to be used. -diff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> m diff +diff :: Has (Diff term1 term2 diff) sig m => term1 -> term2 -> m diff diff a1 a2 = send (Diff a1 a2 pure) -- | Diff an 'Edit.Edit' of terms without specifying the algorithm to be used. -diffEdit :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Edit.Edit term1 term2 -> Algorithm term1 term2 diff m diff +diffEdit :: Has (Diff term1 term2 diff) sig m => Edit.Edit term1 term2 -> Algorithm term1 term2 diff m diff diffEdit = Edit.edit byDeleting byInserting diff -- | Diff a pair of optional terms without specifying the algorithm to be used. -diffMaybe :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Maybe term1 -> Maybe term2 -> Algorithm term1 term2 diff m (Maybe diff) +diffMaybe :: Has (Diff term1 term2 diff) sig m => Maybe term1 -> Maybe term2 -> Algorithm term1 term2 diff m (Maybe diff) diffMaybe (Just a1) (Just a2) = Just <$> diff a1 a2 diffMaybe (Just a1) _ = Just <$> byDeleting a1 diffMaybe _ (Just a2) = Just <$> byInserting a2 diffMaybe _ _ = pure Nothing -- | Diff two terms linearly. -linearly :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff +linearly :: Has (Diff term1 term2 diff) sig m => term1 -> term2 -> Algorithm term1 term2 diff m diff linearly f1 f2 = send (Linear f1 f2 pure) -- | Diff two terms using RWS. -byRWS :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => [term1] -> [term2] -> Algorithm term1 term2 diff m [diff] +byRWS :: Has (Diff term1 term2 diff) sig m => [term1] -> [term2] -> Algorithm term1 term2 diff m [diff] byRWS as1 as2 = send (RWS as1 as2 pure) -- | Delete a term. -byDeleting :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> Algorithm term1 term2 diff m diff +byDeleting :: Has (Diff term1 term2 diff) sig m => term1 -> Algorithm term1 term2 diff m diff byDeleting a1 = sendDiff (Delete a1 pure) -- | Insert a term. -byInserting :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term2 -> Algorithm term1 term2 diff m diff +byInserting :: Has (Diff term1 term2 diff) sig m => term2 -> Algorithm term1 term2 diff m diff byInserting a2 = sendDiff (Insert a2 pure) -- | Replace one term with another. -byReplacing :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff +byReplacing :: Has (Diff term1 term2 diff) sig m => 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 a -> Algorithm term1 term2 diff m a +sendDiff :: Has (Diff term1 term2 diff) sig m => Diff term1 term2 diff m a -> Algorithm term1 term2 diff m a sendDiff = Algorithm . send -- | Diff two terms based on their 'Diffable' instances, performing substructural comparisons iff the initial comparison fails. -algorithmForTerms :: (Carrier sig m, Diffable syntax, Member (Diff (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2)) sig, Member NonDet sig, Alternative m) +algorithmForTerms :: (Diffable syntax, Has (Diff (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2)) sig m, Has NonDet sig m, Alternative m) => Term syntax ann1 -> Term syntax ann2 -> Algorithm (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2) m (Diff.Diff syntax ann1 ann2) @@ -134,12 +134,12 @@ instance Alternative Equivalence where -- | A type class for determining what algorithm to use for diffing two terms. class Diffable f where -- | Construct an algorithm to diff a pair of @f@s populated with disjoint terms. - algorithmFor :: (Alternative m, Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) + algorithmFor :: (Alternative m, Has (Diff term1 term2 diff) sig m, Has NonDet sig m) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) default - algorithmFor :: (Alternative m, Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig) + algorithmFor :: (Alternative m, Generic1 f, GDiffable (Rep1 f), Has (Diff term1 term2 diff) sig m, Has NonDet sig m) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) @@ -182,7 +182,7 @@ class Diffable f where default comparableTo :: (Generic1 f, GDiffable (Rep1 f)) => f term1 -> f term2 -> Bool comparableTo = genericComparableTo -genericAlgorithmFor :: (Alternative m, Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig) +genericAlgorithmFor :: (Alternative m, Generic1 f, GDiffable (Rep1 f),Has (Diff term1 term2 diff) sig m, Has NonDet sig m) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) @@ -230,7 +230,7 @@ instance Diffable NonEmpty where -- | A generic type class for diffing two terms defined by the Generic1 interface. class GDiffable f where - galgorithmFor :: (Alternative m, Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) + galgorithmFor :: (Alternative m, Has (Diff term1 term2 diff) sig m, Has NonDet sig m) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) gtryAlignWith :: Alternative g => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 49a2c019b..d9bdbb5ac 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -5,9 +5,8 @@ module Diffing.Interpreter , stripDiff ) where -import Control.Effect.Carrier -import Control.Effect.Cull -import Control.Effect.NonDet +import Control.Algebra +import Control.Carrier.Cull.Church import qualified Data.Diff as Diff import Data.Edit (Edit, edit) import Data.Term @@ -20,7 +19,7 @@ diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => Term syntax ann1 -> Term syntax ann2 -> Diff.Diff syntax ann1 ann2 -diffTerms t1 t2 = stripDiff (fromMaybe (Diff.comparing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms t1' t2'))))) +diffTerms t1 t2 = stripDiff (fromMaybe (Diff.comparing t1' t2') (run (runCullA (cull (runDiff (algorithmForTerms t1' t2')))))) where (t1', t2') = ( defaultFeatureVectorDecorator t1 , defaultFeatureVectorDecorator t2) @@ -54,21 +53,19 @@ newtype DiffC term1 term2 diff m a = DiffC { runDiffC :: m a } deriving (Alternative, Applicative, Functor, Monad, MonadIO) instance ( Alternative m - , Carrier sig m , Diffable syntax , Eq1 syntax - , Member NonDet sig - , Monad m + , Has NonDet sig m , Traversable syntax ) - => Carrier + => Algebra (Diff (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) :+: sig) (DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m) where - eff (L op) = case op of + alg (L op) = case op of Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.comparing t1 t2) >>= k Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffEdit) f1 f2 >>= k RWS as bs k -> traverse (runDiff . diffEdit) (rws comparableTerms equivalentTerms as bs) >>= k Delete a k -> k (Diff.deleting a) Insert b k -> k (Diff.inserting b) Replace a b k -> k (Diff.comparing a b) - eff (R other) = DiffC . eff . handleCoercible $ other + alg (R other) = DiffC . alg . handleCoercible $ other diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index c34ed9458..c0fa0423f 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -19,13 +19,12 @@ import qualified Data.Text as T import Diffing.Algorithm import System.FilePath.Posix -resolveGoImport :: ( Member (Modules address value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Package.PackageInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member Trace sig - , Carrier sig m +resolveGoImport :: ( Has (Modules address value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Package.PackageInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has Trace sig m ) => ImportPath -> Evaluator term address value m [ModulePath] diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 875ff99fa..f3826b2a6 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -44,11 +44,10 @@ instance Evaluatable VariableName -- file, the complete contents of the included file are treated as though it -- were defined inside that function. -resolvePHPName :: ( Member (Modules address value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Carrier sig m +resolvePHPName :: ( Has (Modules address value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m ) => T.Text -> Evaluator term address value m ModulePath @@ -58,18 +57,17 @@ resolvePHPName n = do where name = toName n toName = T.unpack . dropRelativePrefix . stripQuotes -include :: ( Carrier sig m - , Member (Modules address value) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (State (ScopeGraph address)) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member (State (Heap address address value)) sig - , Member (Abstract.String value) sig - , Member Trace sig +include :: ( Has (Modules address value) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has (State (Heap address address value)) sig m + , Has (Abstract.String value) sig m + , Has Trace sig m , Ord address ) => (term -> Evaluator term address value m value) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index dc56eaa3b..476e4957c 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -56,12 +56,11 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (T.unpack prefix) (Ju -- Subsequent imports of `parent.two` or `parent.three` will execute -- `parent/two/__init__.py` and -- `parent/three/__init__.py` respectively. -resolvePythonModules :: ( Member (Modules address value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member Trace sig - , Carrier sig m +resolvePythonModules :: ( Has (Modules address value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has Trace sig m ) => QualifiedName -> Evaluator term address value m (NonEmpty ModulePath) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index ca1f57760..09bbbe601 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -26,11 +26,10 @@ import System.FilePath.Posix -- TODO: Fully sort out ruby require/load mechanics -- -- require "json" -resolveRubyName :: ( Member (Modules address value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Carrier sig m +resolveRubyName :: ( Has (Modules address value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m ) => Text -> Evaluator term address value m M.ModulePath @@ -41,11 +40,10 @@ resolveRubyName name = do maybeM (throwResolutionError $ NotFoundError name' paths Language.Ruby) modulePath -- load "/root/src/file.rb" -resolveRubyPath :: ( Member (Modules address value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Carrier sig m +resolveRubyPath :: ( Has (Modules address value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m ) => Text -> Evaluator term address value m M.ModulePath @@ -101,9 +99,8 @@ instance Evaluatable Require where insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) pure v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require -doRequire :: ( Member (Boolean value) sig - , Member (Modules address value) sig - , Carrier sig m +doRequire :: ( Has (Boolean value) sig m + , Has (Modules address value) sig m ) => M.ModulePath -> Evaluator term address value m ((address, address), value) @@ -130,19 +127,18 @@ instance Evaluatable Load where shouldWrap <- eval wrap >>= asBool doLoad path shouldWrap -doLoad :: ( Member (Boolean value) sig - , Member (Modules address value) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member (State (ScopeGraph.ScopeGraph address)) sig - , Member (State (Heap address address value)) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member Trace sig +doLoad :: ( Has (Boolean value) sig m + , Has (Modules address value) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has (State (ScopeGraph.ScopeGraph address)) sig m + , Has (State (Heap address address value)) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has Trace sig m , Ord address - , Carrier sig m ) => Text -> Bool diff --git a/src/Language/TypeScript/Resolution.hs b/src/Language/TypeScript/Resolution.hs index d37103a59..b0cf9f1b0 100644 --- a/src/Language/TypeScript/Resolution.hs +++ b/src/Language/TypeScript/Resolution.hs @@ -26,13 +26,12 @@ import qualified Data.Language as Language -- -- NB: TypeScript has a couple of different strategies, but the main one (and the -- only one we support) mimics Node.js. -resolveWithNodejsStrategy :: ( Member (Modules address value) sig - , Member (Reader M.ModuleInfo) sig - , Member (Reader PackageInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member Trace sig - , Carrier sig m +resolveWithNodejsStrategy :: ( Has (Modules address value) sig m + , Has (Reader M.ModuleInfo) sig m + , Has (Reader PackageInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has Trace sig m ) => ImportPath -> [String] @@ -47,13 +46,12 @@ resolveWithNodejsStrategy (ImportPath path _) exts = resolveRelativePa -- /root/src/moduleB.ts -- /root/src/moduleB/package.json (if it specifies a "types" property) -- /root/src/moduleB/index.ts -resolveRelativePath :: ( Member (Modules address value) sig - , Member (Reader M.ModuleInfo) sig - , Member (Reader PackageInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member Trace sig - , Carrier sig m +resolveRelativePath :: ( Has (Modules address value) sig m + , Has (Reader M.ModuleInfo) sig m + , Has (Reader PackageInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has Trace sig m ) => FilePath -> [String] @@ -77,13 +75,12 @@ resolveRelativePath relImportPath exts = do -- -- /root/node_modules/moduleB.ts, etc -- /node_modules/moduleB.ts, etc -resolveNonRelativePath :: ( Member (Modules address value) sig - , Member (Reader M.ModuleInfo) sig - , Member (Reader PackageInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member Trace sig - , Carrier sig m +resolveNonRelativePath :: ( Has (Modules address value) sig m + , Has (Reader M.ModuleInfo) sig m + , Has (Reader PackageInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has Trace sig m ) => FilePath -> [String] @@ -104,10 +101,9 @@ resolveNonRelativePath name exts = do notFound xs = throwResolutionError $ NotFoundError name xs Language.TypeScript -- | Resolve a module name to a ModulePath. -resolveModule :: ( Member (Modules address value) sig - , Member (Reader PackageInfo) sig - , Member Trace sig - , Carrier sig m +resolveModule :: ( Has (Modules address value) sig m + , Has (Reader PackageInfo) sig m + , Has Trace sig m ) => FilePath -- ^ Module path used as directory to search in -> [String] -- ^ File extensions to look for diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index b7102b11a..b11620471 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -237,23 +237,22 @@ instance Ord1 Module where liftCompare = genericLiftCompare instance Show1 Module where liftShowsPrec = genericLiftShowsPrec declareModule :: ( AbstractValue term address value m - , Carrier sig m , Declarations term - , Member (Allocator address) sig - , Member (Deref value) sig - , Member (Object address value) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (EvalError term address value))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member Fresh sig - , Member (Reader ModuleInfo) sig - , Member (Resumable (BaseError (AddressError address value))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Unit value) sig + , Has (Allocator address) sig m + , Has (Deref value) sig m + , Has (Object address value) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (EvalError term address value))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has Fresh sig m + , Has (Reader ModuleInfo) sig m + , Has (Resumable (BaseError (AddressError address value))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Unit value) sig m , Ord address ) => (term -> Evaluator term address value m value) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index 16321ee4d..23406ecc9 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -8,9 +8,8 @@ module Parsing.TreeSitter import Prologue -import Control.Effect.Fail -import Control.Effect.Lift -import Control.Effect.Reader +import Control.Carrier.Fail.Either +import Control.Carrier.Reader import qualified Control.Exception as Exc import Foreign import Foreign.C.Types (CBool (..)) @@ -59,7 +58,7 @@ parseToPreciseAST -> m (Either TSParseException (t Loc)) parseToPreciseAST parseTimeout language blob = runParse parseTimeout language blob $ \ rootPtr -> TS.withCursor (castPtr rootPtr) $ \ cursor -> - runM (runFail (runReader cursor (runReader (Source.bytes (blobSource blob)) (TS.peekNode >>= TS.unmarshalNode)))) + runFail (runReader cursor (runReader (Source.bytes (blobSource blob)) (TS.peekNode >>= TS.unmarshalNode))) >>= either (Exc.throw . UnmarshalFailure) pure instance Exception TSParseException where diff --git a/src/Prologue.hs b/src/Prologue.hs index 51cf2fb06..6bffd7b96 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -2,7 +2,6 @@ module Prologue ( module X , eitherM - , foldMapA , maybeM , maybeLast , fromMaybeLast @@ -22,7 +21,6 @@ import Data.Ix as X (Ix (..)) import Data.List.NonEmpty as X (NonEmpty (..), nonEmpty, some1) import Data.Map as X (Map) import Data.Maybe as X -import Data.Monoid (Alt (..)) import Data.Sequence as X (Seq) import Data.Semilattice.Lower as X (Lower(..)) import Data.Set as X (Set) @@ -35,6 +33,7 @@ import Control.Exception as X hiding (Handler (..), assert, evaluate, throw, thr -- Typeclasses import Control.Applicative as X import Control.Arrow as X ((&&&), (***)) +import Control.Effect.NonDet as X (foldMapA) import Control.Monad as X hiding (fail, return) import Control.Monad.Fail as X (MonadFail (..)) import Control.Monad.IO.Class as X (MonadIO (..)) @@ -52,7 +51,6 @@ import Data.Hashable as X (Hashable, hash, hashUsing, hashWithSalt) import Data.Hashable.Lifted as X (Hashable1(..), hashWithSalt1) import Data.Monoid as X (First (..), Last (..), Monoid (..)) import Data.Monoid.Generic as X -import Data.Profunctor.Unsafe import Data.Proxy as X (Proxy (..)) import Data.Semigroup as X (Semigroup (..)) import Data.Traversable as X @@ -62,11 +60,6 @@ import Data.Typeable as X (Typeable) import GHC.Generics as X (Generic, Generic1) import GHC.Stack as X --- | Fold a collection by mapping each element onto an 'Alternative' action. -foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a -foldMapA f = getAlt #. foldMap (Alt #. f) -{-# INLINE foldMapA #-} - maybeLast :: Foldable t => b -> (a -> b) -> t a -> b maybeLast b f = maybe b f . getLast . foldMap (Last . Just) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 02b496949..e35617099 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -8,10 +8,9 @@ module Rendering.Graph import Algebra.Graph.Export.Dot import Analysis.ConstructorName -import Control.Effect.Fresh -import Control.Effect.Pure -import Control.Effect.Reader -import Control.Effect.State +import Control.Carrier.Fresh.Strict +import Control.Carrier.Reader +import Control.Carrier.State.Strict import Control.Lens import Data.Diff import Data.Edit @@ -32,13 +31,14 @@ renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t - renderTreeGraph = simplify . runGraph . cata toTreeGraph runGraph :: ReaderC (Graph vertex) - (FreshC PureC) (Graph vertex) + (FreshC Identity) (Graph vertex) -> Graph vertex runGraph = run . runFresh' . runReader mempty where -- NB: custom runFresh so that we count starting at 1 in order to avoid -- default values for proto encoding. runFresh' = evalState 1 . runFreshC + runFreshC (FreshC a) = a -- | GraphViz styling for terms termStyle :: (IsString string, Monoid string) => String -> Style TermVertex string @@ -62,7 +62,7 @@ diffStyle name = (defaultStyle (fromString . show . view diffVertexId)) _ -> [] class ToTreeGraph vertex t | t -> vertex where - toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m) => t (m (Graph vertex)) -> m (Graph vertex) + toTreeGraph :: (Has Fresh sig m, Has (Reader (Graph vertex)) sig m) => t (m (Graph vertex)) -> m (Graph vertex) instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph TermVertex (TermF syntax Loc) where @@ -70,9 +70,8 @@ instance (ConstructorName syntax, Foldable syntax) => termAlgebra :: ( ConstructorName syntax , Foldable syntax - , Member Fresh sig - , Member (Reader (Graph TermVertex)) sig - , Carrier sig m + , Has Fresh sig m + , Has (Reader (Graph TermVertex)) sig m ) => TermF syntax Loc (m (Graph TermVertex)) -> m (Graph TermVertex) @@ -117,9 +116,8 @@ instance (ConstructorName syntax, Foldable syntax) => ann a = converting #? Loc.span a diffAlgebra :: ( Foldable f - , Member Fresh sig - , Member (Reader (Graph DiffTreeVertex)) sig - , Carrier sig m + , Has Fresh sig m + , Has (Reader (Graph DiffTreeVertex)) sig m ) => f (m (Graph DiffTreeVertex)) -> DiffTreeVertex'DiffTerm -> m (Graph DiffTreeVertex) diffAlgebra syntax a = do i <- fresh diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 3a70f9a44..16b91759e 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -11,7 +11,9 @@ import qualified Data.Map.Strict as Map import Control.Abstract as Abstract import Control.Abstract.ScopeGraph (runAllocator) -import Control.Effect.Carrier +import Control.Algebra +import Control.Carrier.Error.Either +import Control.Carrier.Reader import Control.Effect.Interpose import Data.Abstract.Evaluatable import Data.Abstract.Module @@ -44,18 +46,18 @@ type DomainC term address value m m)))))))))) -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module. -evaluate :: ( Carrier outerSig outer +evaluate :: ( Algebra outerSig outer , derefSig ~ (Deref value :+: allocatorSig) , derefC ~ DerefC address value allocatorC - , Carrier derefSig derefC + , Algebra derefSig derefC , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig) , allocatorC ~ AllocatorC address (ReaderC ModuleInfo outer) - , Carrier allocatorSig allocatorC + , Algebra allocatorSig allocatorC , Effect outerSig - , Member Fresh outerSig - , Member (Reader (ModuleTable (Module (ModuleResult address value)))) outerSig - , Member (State (Heap address address value)) outerSig - , Member (State (ScopeGraph address)) outerSig + , Has Fresh outerSig outer + , Has (Reader (ModuleTable (Module (ModuleResult address value)))) outerSig outer + , Has (State (Heap address address value)) outerSig outer + , Has (State (ScopeGraph address)) outerSig outer , Ord address ) => proxy (lang :: Language) @@ -109,21 +111,21 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , whileSig ~ (While value :+: booleanSig) , functionC ~ FunctionC term address value whileC , functionSig ~ (Function term address value :+: whileSig) - , Carrier functionSig functionC + , Algebra functionSig functionC , HasPrelude lang - , Member (Allocator address) sig - , Member (Deref value) sig - , Member Fresh sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (Reader ModuleInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (AddressError address value))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member Trace sig + , Has (Allocator address) sig m + , Has (Deref value) sig m + , Has Fresh sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (AddressError address value))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has Trace sig m , Ord address , Show address ) @@ -148,44 +150,43 @@ runDomainEffects runTerm -- | Evaluate a term recursively, applying the passed function at every recursive position. -- -- This calls out to the 'Evaluatable' instances, and can have other functions composed after it to e.g. intercept effects arising in the evaluation of the term. -evalTerm :: ( Carrier sig m - , AbstractValue term address value m +evalTerm :: ( AbstractValue term address value m , AccessControls term , Declarations term , Evaluatable (Base term) , FreeVariables term , HasSpan term - , Member (Allocator address) sig - , Member (Bitwise value) sig - , Member (Boolean value) sig - , Member (Deref value) sig - , Member (Error (LoopControl value)) sig - , Member (Error (Return value)) sig - , Member (Function term address value) sig - , Member (Modules address value) sig - , Member (Numeric value) sig - , Member (Object address value) sig - , Member (Array value) sig - , Member (Hash value) sig - , Member (Reader ModuleInfo) sig - , Member (Reader PackageInfo) sig - , Member (Reader Span) sig - , Member (Resumable (BaseError (AddressError address value))) sig - , Member (Resumable (BaseError (HeapError address))) sig - , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (UnspecializedError address value))) sig - , Member (Resumable (BaseError (EvalError term address value))) sig - , Member (Resumable (BaseError ResolutionError)) sig - , Member (State (Heap address address value)) sig - , Member (State (ScopeGraph address)) sig - , Member (Abstract.String value) sig - , Member (Reader (CurrentFrame address)) sig - , Member (Reader (CurrentScope address)) sig - , Member (State Span) sig - , Member (Unit value) sig - , Member (While value) sig - , Member Fresh sig - , Member Trace sig + , Has (Allocator address) sig m + , Has (Bitwise value) sig m + , Has (Boolean value) sig m + , Has (Deref value) sig m + , Has (Error (LoopControl value)) sig m + , Has (Error (Return value)) sig m + , Has (Function term address value) sig m + , Has (Modules address value) sig m + , Has (Numeric value) sig m + , Has (Object address value) sig m + , Has (Array value) sig m + , Has (Hash value) sig m + , Has (Reader ModuleInfo) sig m + , Has (Reader PackageInfo) sig m + , Has (Reader Span) sig m + , Has (Resumable (BaseError (AddressError address value))) sig m + , Has (Resumable (BaseError (HeapError address))) sig m + , Has (Resumable (BaseError (ScopeError address))) sig m + , Has (Resumable (BaseError (UnspecializedError address value))) sig m + , Has (Resumable (BaseError (EvalError term address value))) sig m + , Has (Resumable (BaseError ResolutionError)) sig m + , Has (State (Heap address address value)) sig m + , Has (State (ScopeGraph address)) sig m + , Has (Abstract.String value) sig m + , Has (Reader (CurrentFrame address)) sig m + , Has (Reader (CurrentScope address)) sig m + , Has (State Span) sig m + , Has (Unit value) sig m + , Has (While value) sig m + , Has Fresh sig m + , Has Trace sig m , Ord address , Recursive term , Show address diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index 55ff2b49b..6465e1310 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -49,25 +49,25 @@ data DiffOutputFormat | DiffDotGraph deriving (Eq, Show) -parseDiffBuilder :: (Traversable t, Member (Error SomeException) sig, Member (Reader Config) sig, Member Telemetry sig, Member Distribute sig, Member Parse sig, Carrier sig m, MonadIO m) => DiffOutputFormat -> t BlobPair -> m Builder +parseDiffBuilder :: (Traversable t, Has (Error SomeException) sig m, Has (Reader Config) sig m, Has Telemetry sig m, Has Distribute sig m, Has Parse sig m, MonadIO m) => DiffOutputFormat -> t BlobPair -> m Builder parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs. parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON parseDiffBuilder DiffSExpression = distributeFoldMap (parsePairWith diffParsers sexprDiff) parseDiffBuilder DiffShow = distributeFoldMap (parsePairWith diffParsers showDiff) parseDiffBuilder DiffDotGraph = distributeFoldMap (parsePairWith diffParsers dotGraphDiff) -jsonDiff :: (Member (Error SomeException) sig, Member Telemetry sig, Member Parse sig, Carrier sig m, MonadIO m) => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) +jsonDiff :: (Has (Error SomeException) sig m, Has Telemetry sig m, Has Parse sig m, MonadIO m) => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonDiff blobPair = parsePairWith diffParsers jsonTreeDiff blobPair `catchError` jsonError blobPair jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON) jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e) -diffGraph :: (Traversable t, Member (Error SomeException) sig, Member Telemetry sig, Member Distribute sig, Member Parse sig, Carrier sig m, MonadIO m) => t BlobPair -> m DiffTreeGraphResponse +diffGraph :: (Traversable t, Has (Error SomeException) sig m, Has Telemetry sig m, Has Distribute sig m, Has Parse sig m, MonadIO m) => t BlobPair -> m DiffTreeGraphResponse diffGraph blobs = do graph <- distributeFor blobs go pure $ defMessage & P.files .~ toList graph where - go :: (Member (Error SomeException) sig, Member Telemetry sig, Member Parse sig, Carrier sig m, MonadIO m) => BlobPair -> m DiffTreeFileGraph + go :: (Has (Error SomeException) sig m, Has Telemetry sig m, Has Parse sig m, MonadIO m) => BlobPair -> m DiffTreeFileGraph go blobPair = parsePairWith diffParsers jsonGraphDiff blobPair `catchError` \(SomeException e) -> pure $ defMessage @@ -82,14 +82,14 @@ diffGraph blobs = do class DOTGraphDiff term where - dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder + dotGraphDiff :: (Has (Reader Config) sig m, Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => DOTGraphDiff term where dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph <=< diffTerms class JSONGraphDiff term where - jsonGraphDiff :: (Carrier sig m, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m DiffTreeFileGraph + jsonGraphDiff :: (Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m DiffTreeFileGraph instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => JSONGraphDiff term where jsonGraphDiff terms = do @@ -108,27 +108,27 @@ instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), class JSONTreeDiff term where - jsonTreeDiff :: (Carrier sig m, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m (Rendering.JSON.JSON "diffs" SomeJSON) + jsonTreeDiff :: (Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m (Rendering.JSON.JSON "diffs" SomeJSON) instance (DiffTerms term, Foldable (Syntax term), ToJSONFields1 (Syntax term)) => JSONTreeDiff term where jsonTreeDiff terms = renderJSONDiff (bimap fst fst terms) <$> diffTerms terms class SExprDiff term where - sexprDiff :: (Carrier sig m, Member (Reader Config) sig, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder + sexprDiff :: (Has (Reader Config) sig m, Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => SExprDiff term where sexprDiff = serialize (SExpression ByConstructorName) <=< diffTerms class ShowDiff term where - showDiff :: (Carrier sig m, Member (Reader Config) sig, Member Telemetry sig, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder + showDiff :: (Has (Reader Config) sig m, Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder instance (DiffTerms term, Foldable (Syntax term), Show1 (Syntax term)) => ShowDiff term where showDiff = serialize Show <=< diffTerms -diffTerms :: (DiffTerms term, Foldable (Syntax term), Member Telemetry sig, Carrier sig m, MonadIO m) +diffTerms :: (DiffTerms term, Foldable (Syntax term), Has Telemetry sig m, MonadIO m) => Edit (Blob, term ann) (Blob, term ann) -> m (Diff (Syntax term) ann ann) diffTerms terms = time "diff" languageTag $ do let diff = diffTermPair (bimap snd snd terms) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 63116a676..7c81593c3 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -32,10 +32,10 @@ import Source.Loc as Loc import Tags.Tagging import qualified Tags.Tagging.Precise as Precise -legacyParseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse +legacyParseSymbols :: (Has Distribute sig m, Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs where - go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m [Legacy.File] + go :: (Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m) => Blob -> m [Legacy.File] go blob@Blob{..} = asks toTagsParsers >>= \ p -> parseWith p (pure . renderToSymbols) blob `catchError` (\(SomeException _) -> pure (pure emptyFile)) where emptyFile = tagsToFile [] @@ -59,15 +59,15 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap , symbolSpan = converting #? Loc.span loc } -parseSymbolsBuilder :: (Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader Config) sig, Member (Reader PerLanguageModes) sig, Carrier sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder +parseSymbolsBuilder :: (Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m, Has (Reader Config) sig m, Has (Reader PerLanguageModes) sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder parseSymbolsBuilder format blobs = parseSymbols blobs >>= serialize format -parseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse +parseSymbols :: (Has Distribute sig m, Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse parseSymbols blobs = do terms <- distributeFor blobs go pure $ defMessage & P.files .~ toList terms where - go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m File + go :: (Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m) => Blob -> m File go blob@Blob{..} = catching $ tagsToFile <$> tagsForBlob blob where catching m = m `catchError` (\(SomeException e) -> pure $ errorFile (show e)) @@ -96,7 +96,7 @@ parseSymbols blobs = do & P.maybe'span ?~ converting # Loc.span loc & P.maybe'docs .~ fmap (flip (set P.docstring) defMessage) docs -tagsForBlob :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig) => Blob -> m [Tag] +tagsForBlob :: (Has (Error SomeException) sig m, Has Parse sig m, Has (Reader PerLanguageModes) sig m) => Blob -> m [Tag] tagsForBlob blob = asks toTagsParsers >>= \p -> parseWith p (pure . tags symbolsToSummarize blob) blob symbolsToSummarize :: [Text] diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 56f8b3bd0..13b1c59b5 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -46,13 +46,13 @@ import Source.Source as Source import qualified Tags.Tag as Tag import qualified Tags.Tagging.Precise as Tagging -diffSummaryBuilder :: (Carrier sig m, Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader Config) sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => Format DiffTreeTOCResponse -> [BlobPair] -> m Builder +diffSummaryBuilder :: (Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m, Has (Reader Config) sig m, Has (Reader PerLanguageModes) sig m, Has Telemetry sig m, MonadIO m) => Format DiffTreeTOCResponse -> [BlobPair] -> m Builder diffSummaryBuilder format blobs = diffSummary blobs >>= serialize format -legacyDiffSummary :: (Carrier sig m, Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => [BlobPair] -> m Summaries +legacyDiffSummary :: (Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m, Has (Reader PerLanguageModes) sig m, Has Telemetry sig m, MonadIO m) => [BlobPair] -> m Summaries legacyDiffSummary = distributeFoldMap go where - go :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => BlobPair -> m Summaries + go :: (Has (Error SomeException) sig m, Has Parse sig m, Has (Reader PerLanguageModes) sig m, Has Telemetry sig m, MonadIO m) => BlobPair -> m Summaries go blobPair = asks summarizeTermParsers >>= \ p -> parsePairWith p (fmap (uncurry (flip Summaries) . bimap toMap toMap . partitionEithers) . summarizeTerms) blobPair `catchError` \(SomeException e) -> pure $ Summaries mempty (toMap [ErrorSummary (T.pack (show e)) lowerBound lang]) @@ -64,12 +64,12 @@ legacyDiffSummary = distributeFoldMap go toMap as = Map.singleton path (toJSON <$> as) -diffSummary :: (Carrier sig m, Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => [BlobPair] -> m DiffTreeTOCResponse +diffSummary :: (Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m, Has (Reader PerLanguageModes) sig m, Has Telemetry sig m, MonadIO m) => [BlobPair] -> m DiffTreeTOCResponse diffSummary blobs = do diff <- distributeFor blobs go pure $ defMessage & P.files .~ diff where - go :: (Carrier sig m, Member (Error SomeException) sig, Member Parse sig, Member (Reader PerLanguageModes) sig, Member Telemetry sig, MonadIO m) => BlobPair -> m TOCSummaryFile + go :: (Has (Error SomeException) sig m, Has Parse sig m, Has (Reader PerLanguageModes) sig m, Has Telemetry sig m, MonadIO m) => BlobPair -> m TOCSummaryFile go blobPair = asks summarizeTermParsers >>= \ p -> parsePairWith p (fmap (uncurry toFile . partitionEithers . map (bimap toError toChange)) . summarizeTerms) blobPair `catchError` \(SomeException e) -> pure $ toFile [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing] [] @@ -103,13 +103,13 @@ summarizeTermParsers :: PerLanguageModes -> Map Language (SomeParser SummarizeTe summarizeTermParsers = allParsers class SummarizeTerms term where - summarizeTerms :: (Member Telemetry sig, Carrier sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary] + summarizeTerms :: (Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary] instance (TermMode term ~ strategy, SummarizeTermsBy strategy term) => SummarizeTerms term where summarizeTerms = summarizeTermsBy @strategy class SummarizeTermsBy (strategy :: LanguageMode) term where - summarizeTermsBy :: (Member Telemetry sig, Carrier sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary] + summarizeTermsBy :: (Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m [Either ErrorSummary TOCSummary] instance (DiffTerms term, HasDeclaration (Syntax term), Traversable (Syntax term), Recursive (term Loc), Base (term Loc) ~ TermF (Syntax term) Loc) => SummarizeTermsBy 'ALaCarte term where summarizeTermsBy = fmap diffTOC . diffTerms . bimap decorateTerm decorateTerm where diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 1b35c2ad6..dcd8b9a3e 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -43,13 +43,13 @@ import qualified Language.JSON as JSON import qualified Language.Python as PythonPrecise -termGraph :: (Traversable t, Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Carrier sig m) => t Blob -> m ParseTreeGraphResponse +termGraph :: (Traversable t, Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m) => t Blob -> m ParseTreeGraphResponse termGraph blobs = do terms <- distributeFor blobs go pure $ defMessage & P.files .~ toList terms where - go :: (Member (Error SomeException) sig, Member Parse sig, Carrier sig m) => Blob -> m ParseTreeFileGraph + go :: (Has (Error SomeException) sig m, Has Parse sig m) => Blob -> m ParseTreeFileGraph go blob = parseWith jsonGraphTermParsers (pure . jsonGraphTerm blob) blob `catchError` \(SomeException e) -> pure $ defMessage @@ -71,7 +71,7 @@ data TermOutputFormat | TermQuiet deriving (Eq, Show) -parseTermBuilder :: (Traversable t, Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m, MonadIO m) +parseTermBuilder :: (Traversable t, Has Distribute sig m, Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m, Has (Reader Config) sig m, MonadIO m) => TermOutputFormat -> t Blob -> m Builder parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs. parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON @@ -80,13 +80,13 @@ parseTermBuilder TermDotGraph = distributeFoldMap (parseWith dotGraphTermPars parseTermBuilder TermShow = distributeFoldMap (\ blob -> asks showTermParsers >>= \ parsers -> parseWith parsers showTerm blob) parseTermBuilder TermQuiet = distributeFoldMap quietTerm -jsonTerm :: (Member (Error SomeException) sig, Member Parse sig, Carrier sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) +jsonTerm :: (Has (Error SomeException) sig m, Has Parse sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON) jsonTerm blob = parseWith jsonTreeTermParsers (pure . jsonTreeTerm blob) blob `catchError` jsonError blob jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "trees" SomeJSON) jsonError blob (SomeException e) = pure $ renderJSONError blob (show e) -quietTerm :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m, MonadIO m) => Blob -> m Builder +quietTerm :: (Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m, Has (Reader Config) sig m, MonadIO m) => Blob -> m Builder quietTerm blob = showTiming blob <$> time' ( asks showTermParsers >>= \ parsers -> parseWith parsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError ) where timingError (SomeException e) = pure (Left (show e)) @@ -99,13 +99,13 @@ showTermParsers :: PerLanguageModes -> Map Language (SomeParser ShowTerm Loc) showTermParsers = allParsers class ShowTerm term where - showTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder + showTerm :: (Has (Reader Config) sig m) => term Loc -> m Builder instance (TermMode term ~ strategy, ShowTermBy strategy term) => ShowTerm term where showTerm = showTermBy @strategy class ShowTermBy (strategy :: LanguageMode) term where - showTermBy :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder + showTermBy :: (Has (Reader Config) sig m) => term Loc -> m Builder instance ShowTermBy 'Precise Java.Term where showTermBy = serialize Show . void . Java.getTerm @@ -149,7 +149,7 @@ dotGraphTermParsers :: Map Language (SomeParser DOTGraphTerm Loc) dotGraphTermParsers = aLaCarteParsers class DOTGraphTerm term where - dotGraphTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder + dotGraphTerm :: (Has (Reader Config) sig m) => term Loc -> m Builder instance (Recursive (term Loc), ToTreeGraph TermVertex (Base (term Loc))) => DOTGraphTerm term where dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index a06a0c7ac..7e1d13894 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -2,7 +2,7 @@ module Semantic.CLI (main) where import qualified Control.Carrier.Parse.Measured as Parse -import Control.Effect.Reader +import Control.Carrier.Reader import Control.Exception as Exc (displayException) import Data.Blob import Data.Blob.IO diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index b4e198e4b..3298e7312 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- TODO: We should kill this entirely, because with fused-effects 1.0 we can unlift the various runConcurrently operations. module Semantic.Distribute ( distribute , distributeFor @@ -9,9 +12,10 @@ module Semantic.Distribute , DistributeC(..) ) where +import Control.Algebra +import Control.Carrier.Lift +import Control.Carrier.Reader import qualified Control.Concurrent.Async as Async -import Control.Effect.Carrier -import Control.Effect.Reader import Control.Monad.IO.Unlift import Control.Parallel.Strategies import Prologue @@ -19,19 +23,19 @@ import Prologue -- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results. -- -- This is a concurrent analogue of 'sequenceA'. -distribute :: (Member Distribute sig, Traversable t, Carrier sig m) => t (m output) -> m (t output) +distribute :: (Has Distribute sig m, Traversable t) => t (m output) -> m (t output) distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute pure) -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results. -- -- This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped). -distributeFor :: (Member Distribute sig, Traversable t, Carrier sig m) => t a -> (a -> m output) -> m (t output) +distributeFor :: (Has Distribute sig m, Traversable t) => t a -> (a -> m output) -> m (t output) distributeFor inputs toTask = distribute (fmap toTask inputs) -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value. -- -- This is a concurrent analogue of 'foldMap'. -distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m) => (a -> m output) -> t a -> m output +distributeFoldMap :: (Has Distribute sig m, Monoid output, Traversable t) => (a -> m output) -> t a -> m output distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) @@ -45,7 +49,7 @@ instance HFunctor Distribute where 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) + thread state handler (Distribute task k) = Distribute (handler (task <$ state)) (handler . fmap k) -- | Evaluate a 'Distribute' effect concurrently. @@ -55,16 +59,22 @@ runDistribute u@(UnliftIO unlift) = unlift . runReader u . runDistributeC withDistribute :: MonadUnliftIO m => DistributeC m a -> m a withDistribute r = withUnliftIO (`runDistribute` r) +instance MonadUnliftIO m => MonadUnliftIO (LiftC m) where + askUnliftIO = LiftC $ withUnliftIO $ \u -> pure (UnliftIO (unliftIO u . runM)) + {-# INLINE askUnliftIO #-} + withRunInIO inner = LiftC $ withRunInIO $ \run -> inner (run . runM) + {-# INLINE withRunInIO #-} + newtype DistributeC m a = DistributeC { runDistributeC :: ReaderC (UnliftIO m) m a } deriving (Functor, Applicative, Monad, MonadIO) -- This can be simpler if we add an instance to fused-effects that takes -- care of this folderol for us (then we can justt derive the MonadUnliftIO instance) -instance (MonadIO m, Carrier sig m) => MonadUnliftIO (DistributeC m) where +instance (MonadIO m, Algebra sig m) => MonadUnliftIO (DistributeC m) where askUnliftIO = DistributeC . ReaderC $ \ u -> pure (UnliftIO (runDistribute u)) -instance (Carrier sig m, MonadIO m) => Carrier (Distribute :+: sig) (DistributeC m) where - eff (L (Distribute task k)) = do +instance (Algebra sig m, MonadIO m) => Algebra (Distribute :+: sig) (DistributeC m) where + alg (L (Distribute task k)) = do handler <- DistributeC ask liftIO (Async.runConcurrently (Async.Concurrently (runDistribute handler task))) >>= k - eff (R other) = DistributeC (eff (R (handleCoercible other))) + alg (R other) = DistributeC (alg (R (handleCoercible other))) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 4ce3562eb..83524dea7 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -36,7 +36,11 @@ 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 Control.Algebra +import Control.Carrier.Fresh.Strict +import Control.Carrier.Reader +import Control.Carrier.Resumable.Resume +import Control.Carrier.State.Strict import Control.Effect.Parse import Control.Lens.Getter import Data.Abstract.Address.Hole as Hole @@ -110,11 +114,10 @@ analysisParsers = Map.fromList , tsxParser ] -runGraph :: ( Member Distribute sig - , Member Parse sig - , Member Resolution sig - , Member Trace sig - , Carrier sig m +runGraph :: ( Has Distribute sig m + , Has Parse sig m + , Has Resolution sig m + , Has Trace sig m , Effect sig ) => GraphType @@ -151,8 +154,7 @@ reifyLanguage = \case runCallGraph :: ( AnalyzeTerm term , HasPrelude lang - , Member Trace sig - , Carrier sig m + , Has Trace sig m , Effect sig ) => Proxy lang @@ -167,7 +169,7 @@ runCallGraph lang includePackages modules package . runHeap . runScopeGraph . caching - . raiseHandler runFresh + . raiseHandler (runFresh 0) . resumingLoadError . resumingUnspecialized . resumingScopeError @@ -193,8 +195,7 @@ runModuleTable = raiseHandler $ runReader lowerBound runImportGraphToModuleInfos :: ( AnalyzeTerm term , HasPrelude lang - , Member Trace sig - , Carrier sig m + , Has Trace sig m , Effect sig ) => Proxy lang @@ -205,8 +206,7 @@ runImportGraphToModuleInfos lang package = runImportGraph lang package allModule runImportGraphToModules :: ( AnalyzeTerm term , HasPrelude lang - , Member Trace sig - , Carrier sig m + , Has Trace sig m , Effect sig ) => Proxy lang @@ -217,8 +217,7 @@ runImportGraphToModules lang package = runImportGraph lang package resolveOrLowe runImportGraph :: ( AnalyzeTerm term , HasPrelude lang - , Member Trace sig - , Carrier sig m + , Has Trace sig m , Effect sig ) => Proxy lang @@ -230,7 +229,7 @@ runImportGraph lang package f . runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) . raiseHandler (runState lowerBound) . runHeap - . raiseHandler runFresh + . raiseHandler (runFresh 0) . resumingLoadError . resumingUnspecialized . resumingScopeError @@ -258,7 +257,7 @@ runScopeGraph :: Ord address runScopeGraph = raiseHandler (runState lowerBound) -- | Parse a list of files into a 'Package'. -parsePackage :: (Member Distribute sig, Member Resolution sig, Member Parse sig, Member Trace sig, Carrier sig m) +parsePackage :: (Has Distribute sig m, Has Resolution sig m, Has Parse sig m, Has Trace sig m) => Parser term -- ^ A parser. -> Project -- ^ Project to parse into a package. -> m (Package (Blob, term)) @@ -272,18 +271,17 @@ parsePackage parser project = do n = Data.Abstract.Evaluatable.name (projectName project) -- TODO: Confirm this is the right `name`. -- | Parse all files in a project into 'Module's. -parseModules :: (Member Distribute sig, Member Parse sig, Carrier sig m) => Parser term -> Project -> m [Module (Blob, term)] +parseModules :: (Has Distribute sig m, Has Parse sig m) => Parser term -> Project -> m [Module (Blob, term)] parseModules parser p = distributeFor (projectBlobs p) (parseModule p parser) -- | Parse a list of packages from a python project. parsePythonPackage :: forall term sig m . ( AnalyzeTerm term - , Member Distribute sig - , Member Parse sig - , Member Resolution sig - , Member Trace sig - , Carrier sig m + , Has Distribute sig m + , Has Parse sig m + , Has Resolution sig m + , Has Trace sig m , Effect sig ) => Parser (term Loc) -- ^ A parser. @@ -293,7 +291,7 @@ parsePythonPackage parser project = do let runAnalysis = runEvaluator @_ @_ @(Value (term Loc) (Hole (Maybe Name) Precise)) . raiseHandler (runState PythonPackage.Unknown) . raiseHandler (runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Hole (Maybe Name) Precise) (Value (term Loc) (Hole (Maybe Name) Precise))))) - . raiseHandler runFresh + . raiseHandler (runFresh 0) . resumingLoadError . resumingUnspecialized -- . resumingEnvironmentError -- TODO: Fix me. Replace with `resumineScopeGraphError`? @@ -342,16 +340,15 @@ parsePythonPackage parser project = do resMap <- Task.resolutionMap p pure (Package.fromModules (Data.Abstract.Evaluatable.name $ projectName p) modules resMap) -- TODO: Confirm this is the right `name`. -parseModule :: (Member Parse sig, Carrier sig m) +parseModule :: Has Parse sig m => Project -> Parser term -> Blob -> m (Module (Blob, term)) parseModule proj parser blob = moduleForBlob (Just (projectRootDir proj)) blob . (,) blob <$> parse parser blob -withTermSpans :: ( Member (Reader Span) sig - , Member (State Span) sig -- last evaluated child's span - , Carrier sig m +withTermSpans :: ( Has (Reader Span) sig m + , Has (State Span) sig m -- last evaluated child's span ) => (term -> Span) -> Open (term -> Evaluator term address value m a) @@ -360,10 +357,9 @@ withTermSpans getSpan recur term = let updatedSpanAlg = withCurrentSpan span (recur term) in modifyChildSpan span updatedSpanAlg -resumingResolutionError :: ( Member Trace sig - , Carrier sig m +resumingResolutionError :: ( Has Trace sig m ) - => Evaluator term address value (ResumableWithC (BaseError ResolutionError) m) a + => Evaluator term address value (ResumableC (BaseError ResolutionError) m) a -> Evaluator term address value m a resumingResolutionError = runResolutionErrorWith $ \ baseError -> do traceError "ResolutionError" baseError @@ -371,25 +367,23 @@ resumingResolutionError = runResolutionErrorWith $ \ baseError -> do NotFoundError nameToResolve _ _ -> pure nameToResolve GoImportError pathToResolve -> pure [pathToResolve] -resumingLoadError :: ( Carrier sig m - , Member Trace sig +resumingLoadError :: ( Has Trace sig m , AbstractHole value , AbstractHole address ) - => Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) m) a + => Evaluator term address value (ResumableC (BaseError (LoadError address value)) m) a -> Evaluator term address value m a resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of ModuleNotFoundError _ -> pure ((hole, hole), hole)) -resumingEvalError :: ( Carrier sig m - , Member Fresh sig - , Member Trace sig +resumingEvalError :: ( Has Fresh sig m + , Has Trace sig m , Show value , Show term , AbstractHole address , AbstractHole value ) - => Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) m) a + => Evaluator term address value (ResumableC (BaseError (EvalError term address value)) m) a -> Evaluator term address value m a resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of AccessControlError{} -> pure hole @@ -406,21 +400,19 @@ resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" base resumingUnspecialized :: ( AbstractHole address , AbstractHole value - , Carrier sig m - , Member Trace sig + , Has Trace sig m ) - => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) m) a + => Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) m) a -> Evaluator term address value m a resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of UnspecializedError _ -> pure hole RefUnspecializedError _ -> pure hole) resumingAddressError :: ( AbstractHole value - , Carrier sig m - , Member Trace sig + , Has Trace sig m , Show address ) - => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) m) a + => Evaluator term address value (ResumableC (BaseError (AddressError address value)) m) a -> Evaluator term address value m a resumingAddressError = runAddressErrorWith $ \ baseError -> do traceError "AddressError" baseError @@ -428,12 +420,11 @@ resumingAddressError = runAddressErrorWith $ \ baseError -> do UnallocatedSlot _ -> pure lowerBound UninitializedSlot _ -> pure hole -resumingValueError :: ( Carrier sig m - , Member Trace sig +resumingValueError :: ( Has Trace sig m , Show address , Show term ) - => Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) m) a + => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) m) a -> Evaluator term address (Value term address) m a resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of CallError{} -> pure hole @@ -450,12 +441,11 @@ resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" b ArrayError{} -> pure lowerBound ArithmeticError{} -> pure hole) -resumingHeapError :: ( Carrier sig m - , AbstractHole address - , Member Trace sig +resumingHeapError :: ( AbstractHole address + , Has Trace sig m , Show address ) - => Evaluator term address value (ResumableWithC (BaseError (HeapError address)) m) a + => Evaluator term address value (ResumableC (BaseError (HeapError address)) m) a -> Evaluator term address value m a resumingHeapError = runHeapErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of CurrentFrameError -> pure hole @@ -465,15 +455,14 @@ resumingHeapError = runHeapErrorWith (\ baseError -> traceError "ScopeError" bas LookupLinksError _ -> pure mempty LookupLinkError _ -> pure hole) -resumingScopeError :: ( Carrier sig m - , Member Trace sig - , AbstractHole (Slot address) - , AbstractHole (Scope address) - , AbstractHole (Path address) - , AbstractHole (Info address) - , AbstractHole address - ) - => Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) m) a +resumingScopeError :: ( Has Trace sig m + , AbstractHole (Slot address) + , AbstractHole (Scope address) + , AbstractHole (Path address) + , AbstractHole (Info address) + , AbstractHole address + ) + => Evaluator term address value (ResumableC (BaseError (ScopeError address)) m) a -> Evaluator term address value m a resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of ScopeError _ _ -> pure hole @@ -484,12 +473,11 @@ resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" b LookupDeclarationScopeError _ -> pure hole DeclarationByNameError _ -> pure hole) -resumingTypeError :: ( Carrier sig m - , Member Trace sig +resumingTypeError :: ( Has Trace sig m , Effect sig , Alternative m ) - => Evaluator term address Type (ResumableWithC (BaseError TypeError) + => Evaluator term address Type (ResumableC (BaseError TypeError) (StateC TypeMap m)) a -> Evaluator term address Type m a @@ -500,5 +488,5 @@ resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseErro prettyShow :: Show a => a -> String prettyShow = hscolour TTY defaultColourPrefs False False "" False . ppShow -traceError :: (Member Trace sig, Show (exc resume), Carrier sig m) => String -> BaseError exc resume -> Evaluator term address value m () +traceError :: (Has Trace sig m, Show (exc resume)) => String -> BaseError exc resume -> Evaluator term address value m () traceError prefix baseError = trace $ prefix <> ": " <> prettyShow baseError diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 3d9c17ee0..65db994d7 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -7,7 +7,7 @@ module Semantic.Resolution , ResolutionC(..) ) where -import Control.Effect.Carrier +import Control.Algebra import Data.Aeson import Data.Aeson.Types (parseMaybe) import Data.Blob @@ -22,7 +22,7 @@ import System.FilePath.Posix import qualified System.Path as Path -nodeJSResolutionMap :: (Member Files sig, Carrier sig m, MonadIO m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath) +nodeJSResolutionMap :: (Has Files sig m, MonadIO m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath) nodeJSResolutionMap rootDir prop excludeDirs = do files <- findFiles (Path.absRel rootDir) [".json"] (fmap Path.absRel excludeDirs) let packageFiles = fileForTypedPath <$> filter ((==) (Path.relFile "package.json") . Path.takeFileName) files @@ -37,7 +37,7 @@ nodeJSResolutionMap rootDir prop excludeDirs = do where relPkgDotJSONPath = makeRelative rootDir path relEntryPath x = takeDirectory relPkgDotJSONPath x -resolutionMap :: (Member Resolution sig, Carrier sig m) => Project -> m (Map FilePath FilePath) +resolutionMap :: Has Resolution sig m => Project -> m (Map FilePath FilePath) resolutionMap Project{..} = case projectLanguage of TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs pure) JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs pure) @@ -57,8 +57,8 @@ runResolution = runResolutionC newtype ResolutionC m a = ResolutionC { runResolutionC :: m a } deriving (Applicative, Functor, Monad, MonadIO) -instance (Member Files sig, Carrier sig m, MonadIO m) => Carrier (Resolution :+: sig) (ResolutionC m) where - eff (R other) = ResolutionC . eff . handleCoercible $ other - eff (L op) = case op of +instance (Has Files sig m, MonadIO m) => Algebra (Resolution :+: sig) (ResolutionC m) where + alg (R other) = ResolutionC . alg . handleCoercible $ other + alg (L op) = case op of NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= k NoResolution k -> k Map.empty diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 12ac48dd1..a2b33febf 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -45,12 +45,10 @@ module Semantic.Task , Telemetry ) where -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.Algebra +import Control.Carrier.Error.Either +import Control.Carrier.Lift +import Control.Carrier.Reader import Control.Effect.Trace import Control.Monad.IO.Class import Data.ByteString.Builder @@ -74,12 +72,10 @@ type TaskC ( TelemetryC ( ErrorC SomeException ( TimeoutC - ( ResourceC - ( CatchC ( DistributeC - ( LiftC IO))))))))))) + ( LiftC IO))))))))) -serialize :: (Member (Reader Config) sig, Carrier sig m) +serialize :: Has (Reader Config) sig m => Format input -> input -> m Builder @@ -104,8 +100,6 @@ runTask taskSession@TaskSession{..} task = do run = runM . withDistribute - . runCatch - . runResource . withTimeout . runError . runTelemetry logger statter @@ -136,6 +130,6 @@ runTraceInTelemetry = runTraceInTelemetryC newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a } deriving (Applicative, Functor, Monad, MonadIO) -instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where - eff (R other) = TraceInTelemetryC . eff . handleCoercible $ other - eff (L (Trace str k)) = writeLog Debug str [] >> k +instance Has Telemetry sig m => Algebra (Trace :+: sig) (TraceInTelemetryC m) where + alg (R other) = TraceInTelemetryC . alg . handleCoercible $ other + alg (L (Trace str k)) = writeLog Debug str [] >> k diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index 0e6c19a52..83313bf94 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DataKinds, DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GADTs, + GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, + UndecidableInstances #-} module Semantic.Task.Files ( Files @@ -16,8 +18,7 @@ module Semantic.Task.Files , FilesArg(..) ) where -import Control.Effect.Carrier -import Control.Effect.Catch +import Control.Algebra import Control.Effect.Error import Data.Blob import Data.Blob.IO @@ -29,8 +30,8 @@ import Prelude hiding (readFile) import Prologue hiding (catch) import Semantic.IO import qualified System.IO as IO hiding (withBinaryFile) -import qualified System.Path.IO as IO (withBinaryFile) import qualified System.Path as Path +import qualified System.Path.IO as IO (withBinaryFile) data Source blob where FromPath :: File -> Source Blob @@ -51,16 +52,16 @@ data Files (m :: * -> *) k deriving instance Functor m => Functor (Files m) instance HFunctor Files where - hmap f (Read s k) = Read s (f . k) + 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) + 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) + thread state handler (Read s k) = Read s (handler . (<$ state) . k) + thread state handler (ReadProject mp p l ps k) = ReadProject mp p l ps (handler . (<$ state) . k) + thread state handler (FindFiles p s ps k) = FindFiles p s ps (handler . (<$ state) . k) + thread state handler (Write d b k) = Write d b (handler . (<$ state) $ k) -- | Run a 'Files' effect in 'IO' runFiles :: FilesC m a -> m a @@ -69,20 +70,20 @@ runFiles = runFilesC newtype FilesC m a = FilesC { runFilesC :: m a } deriving (Functor, Applicative, Monad, MonadIO) -instance (Member (Error SomeException) sig, Member Catch sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where - eff (R other) = FilesC (eff (handleCoercible other)) - eff (L op) = case op of - Read (FromPath path) k -> rethrowing (readBlobFromFile' path) >>= k - Read (FromHandle handle) k -> rethrowing (readBlobsFromHandle handle) >>= k - Read (FromDir dir) k -> rethrowing (readBlobsFromDir dir) >>= k - Read (FromPathPair p1 p2) k -> rethrowing (readFilePair p1 p2) >>= k - Read (FromPairHandle handle) k -> rethrowing (readBlobPairsFromHandle handle) >>= k - ReadProject rootDir dir language excludeDirs k -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) >>= k - FindFiles dir exts excludeDirs k -> rethrowing (findFilesInDir dir exts excludeDirs) >>= k - Write (ToPath path) builder k -> rethrowing (liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))) >> k - Write (ToHandle (WriteHandle handle)) builder k -> rethrowing (liftIO (B.hPutBuilder handle builder)) >> k +instance (Has (Error SomeException) sig m, MonadIO m) => Algebra (Files :+: sig) (FilesC m) where + alg (R other) = FilesC (alg (handleCoercible other)) + alg (L op) = case op of + Read (FromPath path) k -> readBlobFromFile' path >>= k + Read (FromHandle handle) k -> readBlobsFromHandle handle >>= k + Read (FromDir dir) k -> readBlobsFromDir dir >>= k + Read (FromPathPair p1 p2) k -> readFilePair p1 p2 >>= k + Read (FromPairHandle handle) k -> readBlobPairsFromHandle handle >>= k + ReadProject rootDir dir language excludeDirs k -> readProjectFromPaths rootDir dir language excludeDirs >>= k + FindFiles dir exts excludeDirs k -> findFilesInDir dir exts excludeDirs >>= k + Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> k + Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> k -readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob +readBlob :: Has Files sig m => File -> m Blob readBlob file = send (Read (FromPath file) pure) -- Various ways to read in files @@ -91,7 +92,7 @@ data FilesArg | FilesFromPaths [File] -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. -readBlobs :: (Member Files sig, Carrier sig m, MonadIO m) => FilesArg -> m [Blob] +readBlobs :: (Has Files sig m, MonadIO m) => FilesArg -> m [Blob] readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle) pure) readBlobs (FilesFromPaths [path]) = do isDir <- isDirectory (filePath path) @@ -101,20 +102,16 @@ readBlobs (FilesFromPaths [path]) = do readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's. -readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [(File, File)] -> m [BlobPair] +readBlobPairs :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File, File)] -> m [BlobPair] readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure) readBlobPairs (Right paths) = traverse (send . flip Read pure . uncurry FromPathPair) paths -readProject :: (Member Files sig, Carrier sig m) => Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> m Project +readProject :: Has Files sig m => Maybe Path.AbsRelDir -> Path.AbsRelFileDir -> Language -> [Path.AbsRelDir] -> m Project readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs pure) -findFiles :: (Member Files sig, Carrier sig m) => Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> m [Path.AbsRelFile] +findFiles :: Has Files sig m => Path.AbsRelDir -> [String] -> [Path.AbsRelDir] -> m [Path.AbsRelFile] findFiles dir exts paths = send (FindFiles dir exts paths pure) -- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'. -write :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m () +write :: Has Files sig m => Destination -> B.Builder -> m () write dest builder = send (Write dest builder (pure ())) - --- | Catch synchronous exceptions thrown in 'IO' and rethrow them in an 'Error' effect. -rethrowing :: (Member Catch sig, Member (Error SomeException) sig, MonadIO m, Carrier sig m) => m a -> m a -rethrowing act = act `catchSync` throwError @SomeException diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 251e1350d..231171752 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -49,8 +49,8 @@ module Semantic.Telemetry , IgnoreTelemetryC(..) ) where -import Control.Effect.Carrier -import Control.Effect.Reader +import Control.Algebra +import Control.Carrier.Reader import Control.Exception import Control.Monad.IO.Class import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) @@ -117,15 +117,15 @@ queueStat q = liftIO . writeAsyncQueue q -- Eff interface -- | A task which logs a message at a specific log level to stderr. -writeLog :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m () +writeLog :: Has Telemetry sig m => Level -> String -> [(String, String)] -> m () writeLog level message pairs = send (WriteLog level message pairs (pure ())) -- | A task which writes a stat. -writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m () +writeStat :: Has Telemetry sig m => Stat -> m () writeStat stat = send (WriteStat stat (pure ())) -- | A task which measures and stats the timing of another task. -time :: (Member Telemetry sig, Carrier sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output +time :: (Has Telemetry sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output time statName tags task = do (a, stat) <- withTiming statName tags task a <$ writeStat stat @@ -150,13 +150,13 @@ runTelemetry logger statter = runReader (logger, statter) . runTelemetryC newtype TelemetryC m a = TelemetryC { runTelemetryC :: ReaderC (LogQueue, StatQueue) m a } deriving (Applicative, Functor, Monad, MonadIO) -instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where - eff (L op) = do +instance (Algebra sig m, MonadIO m) => Algebra (Telemetry :+: sig) (TelemetryC m) where + alg (L op) = do queues <- TelemetryC ask case op of WriteStat stat k -> queueStat (snd queues) stat *> k WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> k - eff (R other) = TelemetryC (eff (R (handleCoercible other))) + alg (R other) = TelemetryC (alg (R (handleCoercible other))) -- | Run a 'Telemetry' effect by ignoring statting/logging. ignoreTelemetry :: IgnoreTelemetryC m a -> m a @@ -165,7 +165,7 @@ ignoreTelemetry = runIgnoreTelemetryC newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a } deriving (Applicative, Functor, Monad) -instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where - eff (R other) = IgnoreTelemetryC . eff . handleCoercible $ other - eff (L (WriteStat _ k)) = k - eff (L (WriteLog _ _ _ k)) = k +instance Algebra sig m => Algebra (Telemetry :+: sig) (IgnoreTelemetryC m) where + alg (R other) = IgnoreTelemetryC . alg . handleCoercible $ other + alg (L (WriteStat _ k)) = k + alg (L (WriteLog _ _ _ k)) = k diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs index 8b4184ae7..6b6eccd11 100644 --- a/src/Semantic/Timeout.hs +++ b/src/Semantic/Timeout.hs @@ -8,8 +8,8 @@ module Semantic.Timeout , Duration(..) ) where -import Control.Effect.Carrier -import Control.Effect.Reader +import Control.Algebra +import Control.Carrier.Reader import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Data.Duration @@ -18,7 +18,7 @@ import qualified System.Timeout as System -- | Run an action with a timeout. Returns 'Nothing' when no result is available -- within the specified duration. Uses 'System.Timeout.timeout' so all caveats -- about not operating over FFI boundaries apply. -timeout :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output) +timeout :: Has Timeout sig m => Duration -> m output -> m (Maybe output) timeout n = send . flip (Timeout n) pure -- | 'Timeout' effects run other effects, aborting them if they exceed the @@ -32,7 +32,7 @@ instance HFunctor Timeout where 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))) + thread state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just))) -- | Evaulate a 'Timeout' effect. runTimeout :: (forall x . m x -> IO x) @@ -59,8 +59,8 @@ instance MonadUnliftIO m => MonadUnliftIO (TimeoutC m) where askUnliftIO = TimeoutC . ReaderC $ \(Handler h) -> withUnliftIO $ \u -> pure (UnliftIO $ \r -> unliftIO u (runTimeout h r)) -instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where - eff (L (Timeout n task k)) = do +instance (Algebra sig m, MonadIO m) => Algebra (Timeout :+: sig) (TimeoutC m) where + alg (L (Timeout n task k)) = do handler <- TimeoutC ask liftIO (System.timeout (toMicroseconds n) (runHandler handler task)) >>= k - eff (R other) = TimeoutC (eff (R (handleCoercible other))) + alg (R other) = TimeoutC (alg (R (handleCoercible other))) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index f91bbc821..b60d3fcd8 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, PartialTypeSignatures, TypeApplications, TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, PartialTypeSignatures, TypeApplications, TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-} module Semantic.Util ( evaluateProject' @@ -14,9 +14,13 @@ import Prelude hiding (readFile) import Control.Abstract import Control.Abstract.Heap (runHeapError) import Control.Abstract.ScopeGraph (runScopeError) +import Control.Carrier.Fresh.Strict import Control.Carrier.Parse.Simple -import Control.Effect.Lift -import Control.Effect.Trace (runTraceByPrinting) +import Control.Carrier.Lift +import Control.Carrier.Trace.Printing +import Control.Carrier.Reader +import Control.Carrier.Resumable.Either (SomeError (..)) +import Control.Carrier.State.Strict import Control.Exception (displayException) import Control.Lens.Getter import Data.Abstract.Address.Precise as Precise @@ -50,10 +54,10 @@ justEvaluating :: Evaluator term Precise (Value term Precise) _ result justEvaluating = runM . runEvaluator - . raiseHandler runTraceByPrinting + . raiseHandler runTrace . runHeap . runScopeGraph - . raiseHandler runFresh + . raiseHandler (fmap snd . runFresh 0) . fmap reassociate . runLoadError . runUnspecialized diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 04ce85a71..d99cc9394 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -10,7 +10,7 @@ where import Prelude hiding (fail, filter, log) import Prologue hiding (Element, hash) -import Control.Effect.State as Eff +import Control.Carrier.State.Strict as Eff import Data.Abstract.Declarations (Declarations) import Data.Text as T hiding (empty) import Streaming @@ -49,9 +49,7 @@ runTagging lang symbolsToSummarize source type ContextToken = (Text, Range) -contextualizing :: ( Member (State [ContextToken]) sig - , Carrier sig m - ) +contextualizing :: Has (State [ContextToken]) sig m => Source.Source -> (Text -> Maybe Kind) -> Stream (Of Token) m a @@ -68,9 +66,7 @@ contextualizing source toKind = Streaming.mapMaybeM $ \case slice = stripEnd . Source.toText . Source.slice source firstLine = T.take 180 . fst . breakOn "\n" -enterScope, exitScope :: ( Member (State [ContextToken]) sig - , Carrier sig m - ) +enterScope, exitScope :: Has (State [ContextToken]) sig m => ContextToken -> m () enterScope c = modify @[ContextToken] (c :) diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 8b919f66e..22eabdb58 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -3,7 +3,7 @@ module Analysis.Ruby.Spec (spec) where import Control.Abstract (Declaration (..), ScopeError (..)) -import Control.Effect.Resumable (SomeError (..)) +import Control.Carrier.Resumable.Either (SomeError (..)) import Data.Abstract.Evaluatable import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Number as Number diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index a47b375cb..eda224409 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -3,9 +3,10 @@ module Analysis.TypeScript.Spec (spec) where +import Control.Abstract.ScopeGraph hiding (AccessControl(..)) +import Control.Carrier.Resumable.Either (SomeError (..)) import Data.Syntax.Statement (StatementBlock(..)) import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl(..)) -import Control.Abstract.ScopeGraph hiding (AccessControl(..)) import Data.Abstract.Evaluatable import qualified Data.Abstract.Heap as Heap import Data.Abstract.Module (ModuleInfo (..)) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index bc56e1023..8ad56e89c 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -6,7 +6,12 @@ module Control.Abstract.Evaluator.Spec import Control.Abstract as Abstract import qualified Control.Abstract.Heap as Heap -import Control.Effect.Lift +import Control.Carrier.Lift +import Control.Carrier.Error.Either +import Control.Carrier.Fresh.Strict +import Control.Carrier.Resumable.Either +import Control.Carrier.State.Strict +import Control.Carrier.Trace.Ignoring import Data.Abstract.Address.Precise as Precise import Data.Abstract.BaseError import Data.Abstract.Evaluatable @@ -44,10 +49,11 @@ spec = do evaluate = runM - . runTraceByIgnoring + . runTrace . runState (lowerBound @(ScopeGraph Precise)) . runState (lowerBound @(Heap Precise Precise Val)) - . runFresh + . fmap snd + . runFresh 0 . runReader (PackageInfo (SpecHelpers.name "test") mempty) . runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs" Language.Haskell mempty) . evalState (lowerBound @Span) @@ -104,7 +110,7 @@ newtype SpecEff = SpecEff (FreshC (StateC (Heap Precise Precise Val) (StateC (ScopeGraph Precise) - (TraceByIgnoringC + (TraceC (LiftC IO)))))))))))))))))))))))) Val } diff --git a/test/Examples.hs b/test/Examples.hs index 8488801c3..c642f2d97 100644 --- a/test/Examples.hs +++ b/test/Examples.hs @@ -3,12 +3,10 @@ module Main (main) where import Control.Carrier.Parse.Measured -import Control.Effect -import Control.Effect.Reader +import Control.Carrier.Reader +import Control.Concurrent.Async (forConcurrently) import Control.Exception (displayException) import qualified Control.Foldl as Foldl -import Data.Function ((&)) -import Control.Concurrent.Async (forConcurrently) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (ResIO, runResourceT) @@ -16,6 +14,7 @@ import Data.Blob import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Streaming.Char8 as ByteStream import Data.Either +import Data.Function ((&)) import Data.Language (defaultLanguageModes) import Data.Set (Set) import Data.Typeable @@ -119,5 +118,5 @@ knownFailuresForPath tsDir (Just path) ) -parseFilePath :: (Member (Error SomeException) sig, Member Distribute sig, Member Parse sig, Member Files sig, Member (Reader Config) sig, Carrier sig m, MonadIO m) => Path.RelFile -> m Bool +parseFilePath :: (Has (Error SomeException) sig m, Has Distribute sig m, Has Parse sig m, Has Files sig m, Has (Reader Config) sig m, MonadIO m) => Path.RelFile -> m Bool parseFilePath path = readBlob (fileForTypedPath path) >>= runReader defaultLanguageModes . parseTermBuilder @[] TermShow . pure >>= const (pure True) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index f0bff8c6c..369c36667 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -3,7 +3,6 @@ module Rendering.TOC.Spec (spec) where import Analysis.TOCSummary import Control.Effect.Parse -import Control.Effect.Reader import Control.Monad.IO.Class import Data.Aeson hiding (defaultOptions) import Data.Bifunctor @@ -217,7 +216,7 @@ blankDiff = merge (Nothing, Nothing) (inject [ inserting (termIn Nothing (inject -- Diff helpers summarize - :: (Member (Error SomeException) sig, Member Parse sig, Member Telemetry sig, Carrier sig m, MonadIO m) + :: (Has (Error SomeException) sig m, Has Parse sig m, Has Telemetry sig m, MonadIO m) => BlobPair -> m [Either ErrorSummary TOCSummary] summarize = parsePairWith (summarizeTermParsers defaultLanguageModes) summarizeTerms diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index c95b6c1e7..f561a0cea 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -1,7 +1,7 @@ module Semantic.CLI.Spec (testTree) where import Control.Carrier.Parse.Simple -import Control.Effect.Reader +import Control.Carrier.Reader import Data.ByteString.Builder import Semantic.Api hiding (Blob, BlobPair, File) import Semantic.Task diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index d2c0832af..f11135317 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Semantic.Spec (spec) where -import Control.Effect.Reader +import Control.Carrier.Reader import Control.Exception (fromException) import SpecHelpers diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 77420a8df..b0e8a7ebc 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -24,9 +24,13 @@ module SpecHelpers ) where import Control.Abstract +import Control.Carrier.Fresh.Strict import Control.Carrier.Parse.Simple -import Control.Effect.Lift -import Control.Effect.Trace as X (runTraceByIgnoring, runTraceByReturning) +import Control.Carrier.Reader as X +import qualified Control.Carrier.Trace.Ignoring as Trace.Ignoring +import Control.Carrier.Resumable.Either +import Control.Carrier.Lift +import Control.Carrier.State.Strict import Control.Exception (displayException) import Control.Monad ((>=>)) import Control.Monad as X @@ -101,7 +105,7 @@ parseFilePath session path = do res <- runTask session . runParse (configTreeSitterParseTimeout (config session)) . runReader defaultLanguageModes $ parseTermBuilder TermSExpression (toList blob) pure (runBuilder <$> res) -runParseWithConfig :: (Carrier sig m, Member (Reader Config) sig) => ParseC m a -> m a +runParseWithConfig :: Has (Reader Config) sig m => ParseC m a -> m a runParseWithConfig task = asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task -- | Read two files to a BlobPair. @@ -124,7 +128,7 @@ type TestEvaluatingC term ( StateC (Heap Precise Precise (Val term)) ( StateC (ScopeGraph Precise) ( FreshC - ( TraceByIgnoringC + ( Trace.Ignoring.TraceC ( LiftC IO)))))))))))) type TestEvaluatingErrors term = '[ BaseError (AddressError Precise (Val term)) @@ -147,8 +151,9 @@ testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingC term) a -> IO (TestEvaluatingState term a) testEvaluating = runM - . runTraceByIgnoring - . runFresh + . Trace.Ignoring.runTrace + . fmap snd + . runFresh 0 . runEvaluator . runScopeGraph . runHeap diff --git a/test/Tags/Spec.hs b/test/Tags/Spec.hs index 48a194744..15ae4d973 100644 --- a/test/Tags/Spec.hs +++ b/test/Tags/Spec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Tags.Spec (spec) where -import Control.Effect.Reader +import Control.Carrier.Reader import Semantic.Api.Symbols import Source.Loc import SpecHelpers