github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 10:15:55 +03:00
Code Issues Projects Releases Wiki Activity

Assign values using the Store effect.

Browse Source
This commit is contained in:
Rob Rix 2018-05-31 08:58:32 -04:00
parent eb40de097e
commit 21f43cdf4d
7 changed files with 8 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -49,14 +49,11 @@ deref = send . Deref
-- | Write a value to the given address in the 'Store'.
assign :: ( Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
assign :: Member (Store address value) effects
=> address
-> value
-> Evaluator address value effects ()
assign address = modifyHeap . heapInsert address
assign address = send . Assign address
-- | Look up or allocate an address for a 'Name'.
@ -70,9 +67,6 @@ lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
letrec :: ( Member (Store address value) effects
, Member (Env address) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> Name
-> Evaluator address value effects value
@ -109,18 +103,21 @@ variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref
-- Effects
data Store address value return where
Alloc :: Name -> Store address value address
Deref :: address -> Store address value value
Alloc :: Name -> Store address value address
Deref :: address -> Store address value value
Assign :: address -> value -> Store address value ()
runStore :: ( Addressable address effects
, Member (Resumable (AddressError address value)) effects
, Member (State (Heap address (Cell address) value)) effects
, Reducer value (Cell address value)
)
=> Evaluator address value (Store address value ': effects) a
-> Evaluator address value effects a
runStore = interpret $ \ eff -> case eff of
Alloc name -> allocCell name
Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))
Assign addr value -> modifyHeap (heapInsert addr value)
data AddressError address value resume where

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

@ -1,6 +1,5 @@
module Control.Abstract.Primitive where
import Control.Abstract.Addressable
import Control.Abstract.Context
import Control.Abstract.Environment
import Control.Abstract.Evaluator
@ -8,7 +7,6 @@ import Control.Abstract.Heap
import Control.Abstract.Value
import Data.Abstract.Name
import Data.ByteString.Char8 (pack, unpack)
import Data.Semigroup.Reducer hiding (unit)
import Data.Semilattice.Lower
import Prologue
@ -17,9 +15,6 @@ builtin :: ( HasCallStack
, Member (Env address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> String
-> Evaluator address value effects value
@ -45,10 +40,7 @@ defineBuiltins :: ( AbstractValue address value effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Heap address (Cell address) value)) effects
, Member Trace effects
, Ord address
, Reducer value (Cell address value)
)
=> Evaluator address value effects ()
defineBuiltins =

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

@ -15,7 +15,6 @@ module Control.Abstract.Value
, ValueRoots(..)
) where
import Control.Abstract.Addressable
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
@ -25,7 +24,6 @@ import Data.Abstract.Name
import Data.Abstract.Number as Number
import Data.Abstract.Ref
import Data.Scientific (Scientific)
import Data.Semigroup.Reducer hiding (unit)
import Data.Semilattice.Lower
import Prelude
import Prologue hiding (TypeError)
@ -188,9 +186,7 @@ doWhile body cond = loop $ \ continue -> body *> do
makeNamespace :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
, Member (Store address value) effects
)
=> Name
-> address

7
src/Data/Abstract/Type.hs
View File

@ -10,7 +10,6 @@ module Data.Abstract.Type
import Control.Abstract
import Data.Abstract.Environment as Env
import Data.Semigroup.Foldable (foldMap1)
import Data.Semigroup.Reducer (Reducer)
import Prologue hiding (TypeError)
type TName = Int
@ -121,9 +120,6 @@ instance ( Member (Store address Type) effects
, Member Fresh effects
, Member (Resumable TypeError) effects
, Member (Return Type) effects
, Member (State (Heap address (Cell address) Type)) effects
, Ord address
, Reducer Type (Cell address Type)
)
=> AbstractFunction address Type effects where
closure names _ body = do
@ -151,9 +147,6 @@ instance ( Member (Store address Type) effects
, Member NonDet effects
, Member (Resumable TypeError) effects
, Member (Return Type) effects
, Member (State (Heap address (Cell address) Type)) effects
, Ord address
, Reducer Type (Cell address Type)
)
=> AbstractValue address Type effects where
array fields = do

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

@ -10,7 +10,6 @@ import Data.Coerce
import Data.List (genericIndex, genericLength)
import Data.Scientific (Scientific)
import Data.Scientific.Exts
import Data.Semigroup.Reducer
import qualified Data.Set as Set
import Prologue
@ -62,9 +61,6 @@ instance ( Coercible body (Eff effects)
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError address body)) effects
, Member (Return (Value address body)) effects
, Member (State (Heap address (Cell address) (Value address body))) effects
, Ord address
, Reducer (Value address body) (Cell address (Value address body))
, Show address
)
=> AbstractFunction address (Value address body) effects where
@ -116,9 +112,6 @@ instance ( Coercible body (Eff effects)
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError address body)) effects
, Member (Return (Value address body)) effects
, Member (State (Heap address (Cell address) (Value address body))) effects
, Ord address
, Reducer (Value address body) (Cell address (Value address body))
, Show address
)
=> AbstractValue address (Value address body) effects where

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

@ -16,7 +16,6 @@ import System.FilePath.Posix
import qualified Data.ByteString.Char8 as BC
import qualified Data.Language as Language
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Semigroup.Reducer as Reducer
data QualifiedName
= QualifiedName (NonEmpty FilePath)
@ -131,9 +130,6 @@ evalQualifiedImport :: ( AbstractValue address value effects
, Member (Store address value) effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer.Reducer value (Cell address value)
)
=> Name -> ModulePath -> Evaluator address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do

4
src/Language/TypeScript/Syntax.hs
View File

@ -12,7 +12,6 @@ import qualified Data.ByteString.Char8 as BC
import Data.JSON.Fields
import qualified Data.Language as Language
import qualified Data.Map as Map
import Data.Semigroup.Reducer (Reducer)
import Diffing.Algorithm
import Prelude
import Prologue
@ -137,9 +136,6 @@ evalRequire :: ( AbstractValue address value effects
, Member (Store address value) effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (State (Heap address (Cell address) value)) effects
, Ord address
, Reducer value (Cell address value)
)
=> M.ModulePath
-> Name