1
1
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00

Merge remote-tracking branch 'origin/master' into test-precise-parsing

This commit is contained in:
Timothy Clem 2019-12-13 13:13:54 -08:00
commit 8ade6db251
98 changed files with 1611 additions and 1675 deletions

View File

@ -41,4 +41,4 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/antitypical/fused-syntax.git
tag: 6b412694e64cc275ed06513b3c360f03bb1f04fd
tag: d11e14581217590a5c67f79cbaeee35ac8acee6a

5
script/fix-broken-cabal-store Executable file
View File

@ -0,0 +1,5 @@
#!/bin/bash
rm -rf ~/.cabal/store/ghc-8.6.5/tr-sttr*
rm -rf ~/.cabal/store/ghc-8.6.5/lib/libHStr-sttr*
rm -rf ~/.cabal/store/ghc-8.6.5/package.db/tr-sttr*

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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 ()
@ -141,9 +139,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)
)

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -3,9 +3,8 @@
module Main (main) where
import Control.Carrier.Parse.Measured
import Control.Carrier.Reader
import Control.Concurrent.Async (forConcurrently)
import Control.Effect
import Control.Effect.Reader
import Control.Exception (displayException)
import qualified Control.Foldl as Foldl
import Control.Lens
@ -26,6 +25,7 @@ import System.Path ((</>))
import qualified System.Path as Path
import qualified System.Process as Process
import Data.Flag
import Proto.Semantic as P hiding (Blob, BlobPair)
import Proto.Semantic_Fields as P
@ -175,11 +175,10 @@ knownFailuresForPath tsDir (Just path)
)
parseSymbolsFilePath ::
( Member (Error SomeException) sig
, Member Distribute sig
, Member Parse sig
, Member Files sig
, Carrier sig m
( Has (Error SomeException) sig m
, Has Distribute sig m
, Has Parse sig m
, Has Files sig m
)
=> PerLanguageModes
-> Path.RelFile

View File

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

View File

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

View File

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

View File

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

View File

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