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

LoopControl operates on values, not ValueRefs.

Browse Source
This commit is contained in:
Rob Rix 2018-12-07 12:52:51 -05:00
parent 09d616788e
commit 36a7c31166
7 changed files with 38 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
src/Control/Abstract/Evaluator.hs
View File

@ -27,7 +27,6 @@ import Control.Effect.Resumable as X
import Control.Effect.State as X
import Control.Effect.Trace as X
import Control.Monad.IO.Class
import Data.Abstract.Ref
import Data.Coerce
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.
@ -78,35 +77,35 @@ runReturn = raiseHandler $ fmap (either unReturn id) . runError
-- | Effects for control flow around loops (breaking and continuing).
data LoopControl address value
= Break { unLoopControl :: ValueRef address value }
| Continue { unLoopControl :: ValueRef address value }
data LoopControl value
= Break { unLoopControl :: value }
| Continue { unLoopControl :: value }
| Abort
deriving (Eq, Ord, Show)
throwBreak :: (Member (Error (LoopControl address value)) sig, Carrier sig m)
=> ValueRef address value
-> Evaluator term address value m (ValueRef address value)
throwBreak :: (Member (Error (LoopControl value)) sig, Carrier sig m)
=> value
-> Evaluator term address value m value
throwBreak = throwError . Break
throwContinue :: (Member (Error (LoopControl address value)) sig, Carrier sig m)
=> ValueRef address value
-> Evaluator term address value m (ValueRef address value)
throwContinue :: (Member (Error (LoopControl value)) sig, Carrier sig m)
=> value
-> Evaluator term address value m value
throwContinue = throwError . Continue
throwAbort :: forall term address sig m value a . (Member (Error (LoopControl address value)) sig , Carrier sig m)
throwAbort :: forall term address sig m value a . (Member (Error (LoopControl value)) sig, Carrier sig m)
=> Evaluator term address value m a
throwAbort = throwError (Abort @address @value)
throwAbort = throwError (Abort @value)
catchLoopControl :: ( Member (Error (LoopControl address value)) sig
catchLoopControl :: ( Member (Error (LoopControl value)) sig
, Carrier sig m
)
=> Evaluator term address value m a
-> (LoopControl address value -> 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, Effect sig)
=> Evaluator term address value (ErrorC (LoopControl address value) (Eff m)) (ValueRef address value)
-> Evaluator term address value m (ValueRef address value)
=> Evaluator term address value (ErrorC (LoopControl value) (Eff m)) value
-> Evaluator term address value m value
runLoopControl = raiseHandler $ fmap (either unLoopControl id) . runError

4
src/Control/Abstract/PythonPackage.hs
View File

@ -28,7 +28,7 @@ runPythonPackaging :: ( Carrier sig m
, Member (State Strategy) sig
, Member (Allocator address) sig
, Member (Deref (Value term address)) sig
, Member (Error (LoopControl address (Value term address))) sig
, Member (Error (LoopControl (Value term address))) sig
, Member (Error (Return (Value term address))) sig
, Member (Reader ModuleInfo) sig
, Member (Reader PackageInfo) sig
@ -48,7 +48,7 @@ instance ( Carrier sig m
, Member (Allocator address) sig
, Member (Boolean (Value term address)) sig
, Member (Deref (Value term address)) sig
, Member (Error (LoopControl address (Value term address))) sig
, Member (Error (LoopControl (Value term address))) sig
, Member (Error (Return (Value term address))) sig
, Member Fresh sig
, Member (Function term address (Value term address)) sig

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

@ -48,7 +48,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, Member (While address value) sig
, Member (Deref value) sig
, Member (State (ScopeGraph address)) sig
, Member (Error (LoopControl address value)) sig
, Member (Error (LoopControl value)) sig
, Member (Error (Return value)) sig
, Member Fresh sig
, Member (Function term address value) sig

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

@ -129,7 +129,7 @@ instance ( Member (Reader ModuleInfo) sig
instance forall sig m term address. ( Carrier sig m
, Member (Abstract.Boolean (Value term address)) sig
, Member (Error (LoopControl address (Value term address))) sig
, Member (Error (LoopControl (Value term address))) sig
, Member (Interpose (Resumable (BaseError (UnspecializedError (Value term address))))) sig
, Show address
, Show term
@ -137,20 +137,20 @@ instance forall sig m term address. ( Carrier sig m
=> Carrier (Abstract.While address (Value term address) :+: sig) (WhileC address (Value term address) (Eff m)) where
ret = WhileC . ret
eff = WhileC . handleSum (eff . handleCoercible) (\case
Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (loop (\continue -> do
Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address)))) (runEvaluator (rvalBox =<< loop (\continue -> do
cond' <- Evaluator (runWhileC cond)
-- `interpose` is used to handle 'UnspecializedError's and abort out of the
-- loop, otherwise under concrete semantics we run the risk of the
-- conditional always being true and getting stuck in an infinite loop.
ifthenelse cond' (Evaluator (runWhileC body) *> continue) (rvalBox Unit))))
(\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @address @(Value term address)))
ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit))))
(\(Resumable (BaseError _ _ (UnspecializedError _)) _) -> throwError (Abort @(Value term address)))
>>= runWhileC . k)
where
loop x = catchLoopControl (fix x) $ \case
Break valueRef -> pure valueRef
Abort -> rvalBox unit
Break value -> pure value
Abort -> pure unit
-- FIXME: Figure out how to deal with this. Ruby treats this as the result
-- of the current block iteration, while PHP specifies a breakout level
-- and TypeScript appears to take a label.
@ -206,7 +206,7 @@ instance (Show address, Show term) => AbstractIntro (Value term address) where
instance ( Member (Allocator address) sig
, Member (Abstract.Boolean (Value term address)) sig
, Member (Deref (Value term address)) sig
, Member (Error (LoopControl address (Value term address))) sig
, Member (Error (LoopControl (Value term address))) sig
, Member (Error (Return (Value term address))) sig
, Member Fresh sig
, Member (Reader ModuleInfo) sig

4
src/Data/Syntax/Statement.hs
View File

@ -282,7 +282,7 @@ instance Ord1 Break where liftCompare = genericLiftCompare
instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Break where
eval eval (Break x) = eval x >>= throwBreak
eval eval (Break x) = eval x >>= Abstract.value >>= throwBreak >>= rvalBox
instance Tokenize Break where
tokenize (Break b) = yield (Token.Flow Token.Break) *> b
@ -295,7 +295,7 @@ instance Ord1 Continue where liftCompare = genericLiftCompare
instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Continue where
eval eval (Continue x) = eval x >>= throwContinue
eval eval (Continue x) = eval x >>= Abstract.value >>= throwContinue >>= rvalBox
instance Tokenize Continue where
tokenize (Continue c) = yield (Token.Flow Token.Continue) *> c

18
src/Semantic/Analysis.hs
View File

@ -15,13 +15,13 @@ import Prologue
import qualified Data.Map.Strict as Map
type ModuleC address value m
= ErrorC (LoopControl address value) (Eff
( ErrorC (Return value) (Eff
( ReaderC (CurrentScope address) (Eff
( ReaderC (CurrentFrame address) (Eff
( DerefC address value (Eff
( AllocatorC address (Eff
( ReaderC ModuleInfo (Eff
= ErrorC (LoopControl value) (Eff
( ErrorC (Return value) (Eff
( ReaderC (CurrentScope address) (Eff
( ReaderC (CurrentFrame address) (Eff
( DerefC address value (Eff
( AllocatorC address (Eff
( ReaderC ModuleInfo (Eff
m)))))))))))))
type ValueC term address value m
@ -107,8 +107,8 @@ evaluate lang perModule runTerm modules = do
. raiseHandler (runReader (CurrentScope scopeAddress))
. (>>= rvalBox)
. runReturn
. (>>= value)
. runLoopControl
. (>>= value)
runValueEffects = raiseHandler runInterpose . runBoolean . runWhile . runFunction runTerm . either ((*> rvalBox unit) . definePrelude) runTerm
@ -124,7 +124,7 @@ evalTerm :: ( Carrier sig m
, Member (Allocator address) sig
, Member (Boolean value) sig
, Member (Deref value) sig
, Member (Error (LoopControl address value)) sig
, Member (Error (LoopControl value)) sig
, Member (Error (Return value)) sig
, Member (Function term address value) sig
, Member (Modules address value) sig

4
test/Control/Abstract/Evaluator/Spec.hs
View File

@ -76,8 +76,8 @@ evaluate
. runAllocator
. (>>= rvalBox)
. runReturn
. (>>= Abstract.value)
. runLoopControl
. (>>= Abstract.value)
. runBoolean
. runFunction runSpecEff
$ action
@ -90,7 +90,7 @@ type Val = Value SpecEff Precise
newtype SpecEff = SpecEff
{ runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val
(Eff (BooleanC Val
(Eff (ErrorC (LoopControl Precise Val)
(Eff (ErrorC (LoopControl Val)
(Eff (ErrorC (Return Val)
(Eff (AllocatorC Precise
(Eff (DerefC Precise Val