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

Rephrase Deref to closely mirror the Derefable class.

Browse Source
This commit is contained in:
Rob Rix 2018-08-10 15:55:29 -04:00
parent e99215de9c
commit 9afa2e5f4e
10 changed files with 88 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -59,6 +59,8 @@ modifyHeap = modify'
box :: ( Member (Allocator address) effects
, Member (Deref address value) effects
, Member Fresh effects
, Member (State (Heap address value)) effects
, Ord address
)
=> value
-> Evaluator address value effects address
@ -72,16 +74,30 @@ alloc :: Member (Allocator address) effects => Name -> Evaluator address value e
alloc = send . Alloc
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
deref :: Member (Deref address value) effects => address -> Evaluator address value effects value
deref = send . Deref
deref :: ( Member (Deref address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> address
-> Evaluator address value effects value
deref addr = gets (heapLookup addr) >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= send . DerefCell addr >>= maybeM (throwAddressError (UninitializedAddress addr))
-- | Write a value to the given address in the 'Allocator'.
assign :: Member (Deref address value) effects
assign :: ( Member (Deref address value) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> address
-> value
-> Evaluator address value effects ()
assign address = send . Assign address
assign addr value = do
heap <- getHeap
cell <- send (AssignCell addr value (fromMaybe lowerBound (heapLookup addr heap)))
putHeap (heapInit addr cell heap)
-- | Look up or allocate an address for a 'Name'.
@ -96,6 +112,8 @@ lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
letrec :: ( Member (Allocator address) effects
, Member (Deref address value) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> Evaluator address value effects value
@ -160,8 +178,8 @@ data Allocator address (m :: * -> *) return where
GC :: Live address -> Allocator address m ()
data Deref address value (m :: * -> *) return where
Deref :: address -> Deref address value m value
Assign :: address -> value -> Deref address value m ()
DerefCell :: address -> Set value -> Deref address value m (Maybe value)
AssignCell :: address -> value -> Set value -> Deref address value m (Set value)
runAllocator :: ( Allocatable address effects
, Member (State (Heap address value)) effects
@ -175,21 +193,14 @@ runAllocator = interpret $ \ eff -> case eff of
GC roots -> modifyHeap (heapRestrict <*> reachable roots)
runDeref :: ( Derefable address effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address value)) effects
, Ord value
, PureEffects effects
)
=> Evaluator address value (Deref address value ': effects) a
-> Evaluator address value effects a
runDeref = interpret $ \ eff -> case eff of
Deref addr -> heapLookup addr <$> get >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwAddressError (UninitializedAddress addr))
Assign addr value -> do
heap <- getHeap
cell <- assignCell addr value (fromMaybe mempty (heapLookup addr heap))
putHeap (heapInit addr cell heap)
DerefCell addr cell -> derefCell addr cell
AssignCell addr value cell -> assignCell addr value cell
instance PureEffect (Allocator address)
@ -200,8 +211,8 @@ instance Effect (Allocator address) where
instance PureEffect (Deref address value)
instance Effect (Deref address value) where
handleState c dist (Request (Deref addr) k) = Request (Deref addr) (dist . (<$ c) . k)
handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (dist . (<$ c) . k)
handleState c dist (Request (DerefCell addr cell) k) = Request (DerefCell addr cell) (dist . (<$ c) . k)
handleState c dist (Request (AssignCell addr value cell) k) = Request (AssignCell addr value cell) (dist . (<$ c) . k)
data AddressError address value resume where
UnallocatedAddress :: address -> AddressError address value (Set value)

12
src/Control/Abstract/Primitive.hs
View File

@ -26,6 +26,8 @@ define :: ( HasCallStack
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> Evaluator address value effects value
@ -42,6 +44,8 @@ defineClass :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> [address]
@ -58,6 +62,8 @@ defineNamespace :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> Evaluator address value effects a
@ -103,8 +109,11 @@ builtInPrint :: ( AbstractValue address value effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> Evaluator address value effects value
builtInPrint = lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)
@ -118,7 +127,10 @@ builtInExport :: ( AbstractValue address value effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Evaluator address value effects value
builtInExport = lambda (\ v -> do

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

@ -202,6 +202,8 @@ doWhile body cond = loop $ \ continue -> body *> do
makeNamespace :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Env address) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name
-> address
@ -233,7 +235,10 @@ value :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> ValueRef address
-> Evaluator address value effects value
@ -245,7 +250,10 @@ subtermValue :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> Evaluator address value effects value
@ -279,6 +287,8 @@ subtermAddress = address <=< subtermRef
rvalBox :: ( Member (Allocator address) effects
, Member (Deref address value) effects
, Member Fresh effects
, Member (State (Heap address value)) effects
, Ord address
)
=> value
-> Evaluator address value effects (ValueRef address)

6
src/Data/Abstract/Evaluatable.hs
View File

@ -59,11 +59,14 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (Resumable (BaseError EvalError)) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
eval expr = do
@ -147,8 +150,11 @@ class HasPrelude (language :: Language) where
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> proxy language
-> Evaluator address value effects ()

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

@ -5,6 +5,7 @@ module Data.Abstract.Value.Abstract
) where
import Control.Abstract as Abstract
import Data.Abstract.BaseError
import Data.Abstract.Environment as Env
import Prologue
@ -17,6 +18,11 @@ runFunction :: ( Member (Allocator address) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address Abstract))) effects
, Member (State (Heap address Abstract)) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Abstract (Function address Abstract ': effects) a
@ -57,6 +63,8 @@ instance ( Member (Allocator address) effects
, Member (Deref address Abstract) effects
, Member Fresh effects
, Member NonDet effects
, Member (State (Heap address Abstract)) effects
, Ord address
)
=> AbstractValue address Abstract effects where
array _ = pure Abstract

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

@ -69,7 +69,10 @@ runFunction :: ( Member (Allocator address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (State (Heap address (Value address body))) effects
, Ord address
, PureEffects effects
)
=> (body address -> Evaluator address (Value address body) (Abstract.Function address (Value address body) ': effects) address)
@ -113,6 +116,11 @@ instance Show address => AbstractIntro (Value address body) where
null = Null
materializeEnvironment :: ( Member (Deref address (Value address body)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (State (Heap address (Value address body))) effects
, Ord address
)
=> Value address body
-> Evaluator address (Value address body) effects (Maybe (Environment address))
@ -146,6 +154,9 @@ instance ( Coercible body (Eff effects)
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
, Member (State (Heap address (Value address body))) effects
, Ord address
, Show address
)
=> AbstractValue address (Value address body) effects where

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

@ -236,7 +236,10 @@ runFunction :: ( Member (Allocator address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (State (Heap address Type)) effects
, Member (State TypeMap) effects
, Ord address
, PureEffects effects
)
=> Evaluator address Type (Abstract.Function address Type ': effects) a
@ -283,8 +286,11 @@ instance ( Member (Allocator address) effects
, Member NonDet effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address Type))) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State (Heap address Type)) effects
, Member (State TypeMap) effects
, Ord address
)
=> AbstractValue address Type effects where
array fields = do

3
src/Language/PHP/Syntax.hs
View File

@ -56,9 +56,12 @@ include :: ( AbstractValue address value effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Heap address value)) effects
, Member Trace effects
, Ord address
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> (ModulePath -> Evaluator address value effects (ModuleResult address))

2
src/Language/Python/Syntax.hs
View File

@ -151,6 +151,8 @@ evalQualifiedImport :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> Name -> ModulePath -> Evaluator address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do

2
src/Language/TypeScript/Resolution.hs
View File

@ -168,6 +168,8 @@ evalRequire :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (State (Heap address value)) effects
, Ord address
)
=> M.ModulePath
-> Name