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

Variable lookup is total, failing when the Env effect is run instead.

Browse Source
This commit is contained in:
Rob Rix 2018-06-06 08:22:42 -04:00
parent 946ac38f0d
commit 6fdf2c274e
9 changed files with 15 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/Analysis/Abstract/Caching.hs
View File

@ -83,7 +83,6 @@ convergingModules :: ( AbstractValue address value effects
, Member NonDet effects
, Member (Reader (Cache term address (Cell address) value)) effects
, Member (Reader (Live address)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (State (Cache term address (Cell address) value)) effects
, Member (Env address) effects
, Member (State (Heap address (Cell address) value)) effects

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

@ -126,7 +126,7 @@ variableDefinition :: ( Member (Env (Hole (Located address))) effects
=> Name
-> TermEvaluator term (Hole (Located address)) value effects ()
variableDefinition name = do
graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe) <$> TermEvaluator (lookupEnv name)
graph <- maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe <$> TermEvaluator (lookupEnv name)
appendGraph (vertex (Variable (unName name)) `connect` graph)
appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects ()

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

@ -36,7 +36,7 @@ export name alias addr = send (Export name alias addr)
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address)
lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects address
lookupEnv name = send (Lookup name)
-- | Bind a 'Name' to an address in the current scope.
@ -61,7 +61,7 @@ close = send . Close
-- Effects
data Env address return where
Lookup :: Name -> Env address (Maybe address)
Lookup :: Name -> Env address address
Bind :: Name -> address -> Env address ()
Close :: Set Name -> Env address (Environment address)
Push :: Env address ()
@ -70,13 +70,14 @@ data Env address return where
Export :: Name -> Name -> Maybe address -> Env address ()
handleEnv :: forall address effects value result
. ( Member (State (Environment address)) effects
. ( Member (Resumable (EnvironmentError address)) effects
, Member (State (Environment address)) effects
, Member (State (Exports address)) effects
)
=> Env address result
-> Evaluator address value effects result
handleEnv = \case
Lookup name -> Env.lookup name <$> get
Lookup name -> Env.lookup name <$> get >>= maybeM (freeVariableError name)
Bind name addr -> modify (Env.insert name addr)
Close names -> Env.intersect names <$> get
Push -> modify (Env.push @address)
@ -84,7 +85,8 @@ handleEnv = \case
GetEnv -> get
Export name alias addr -> modify (Exports.insert name alias addr)
runEnv :: Environment address
runEnv :: Member (Resumable (EnvironmentError address)) effects
=> Environment address
-> Evaluator address value (Env address ': effects) a
-> Evaluator address value effects (a, Environment address)
runEnv initial = fmap (uncurry filterEnv . first (fmap Env.head)) . runState lowerBound . runState (Env.push initial) . reinterpret2 handleEnv

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

@ -70,12 +70,10 @@ assign address = send . Assign address
-- | Look up or allocate an address for a 'Name'.
lookupOrAlloc :: ( Member (Allocator address value) effects
, Member (Env address) effects
)
lookupOrAlloc :: Member (Env address) effects
=> Name
-> Evaluator address value effects address
lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name)
lookupOrAlloc = lookupEnv
letrec :: ( Member (Allocator address value) effects
@ -91,14 +89,12 @@ letrec name body = do
pure (v, addr)
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
letrec' :: ( Member (Allocator address value) effects
, Member (Env address) effects
)
letrec' :: Member (Env address) effects
=> Name
-> (address -> Evaluator address value effects value)
-> Evaluator address value effects value
letrec' name body = do
addr <- lookupOrAlloc name
addr <- lookupEnv name
v <- locally (body addr)
v <$ bind name addr
@ -106,11 +102,10 @@ letrec' name body = do
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: ( Member (Allocator address value) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
)
=> Name
-> Evaluator address value effects value
variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref
variable name = lookupEnv name >>= deref
-- Garbage collection

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

@ -39,7 +39,6 @@ defineBuiltins :: ( AbstractValue address value effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member Trace effects
)
=> Evaluator address value effects ()

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

@ -214,7 +214,6 @@ evaluateInScopedEnv scopedEnvTerm term = do
value :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
)
=> ValueRef value
-> Evaluator address value effects value
@ -226,7 +225,6 @@ value (Rval val) = pure val
subtermValue :: ( AbstractValue address value effects
, Member (Allocator address value) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
)
=> Subterm term (Evaluator address value effects (ValueRef value))
-> Evaluator address value effects value

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

@ -59,7 +59,6 @@ type EvaluatableConstraints term address value effects =
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable EvalError) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (Unspecialized value)) effects
@ -78,6 +77,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer
, Member Fail outer
, Member Fresh outer
, Member (Resumable (AddressError address value)) outer
, Member (Resumable (EnvironmentError address)) outer
, Member (Resumable (LoadError address value)) outer
, Member (State (Heap address (Cell address) value)) outer
, Member (State (ModuleTable (Maybe (value, Environment address)))) outer

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

@ -127,8 +127,7 @@ instance ( Coercible body (Eff effects)
pure $ Class n (mergeEnvs product env)
namespace n env = do
maybeAddr <- lookupEnv n
env' <- maybe (pure emptyEnv) (asNamespaceEnv <=< deref) maybeAddr
env' <- lookupEnv n >>= deref >>= asNamespaceEnv
pure (Namespace n (Env.mergeNewer env' env))
where asNamespaceEnv v
| Namespace _ env' <- v = pure env'

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

@ -52,7 +52,6 @@ include :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Modules address value) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (EnvironmentError address)) effects
, Member Trace effects
)
=> Subterm term (Evaluator address value effects (ValueRef value))