github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00
Code Issues Projects Releases Wiki Activity

Get interpose working and an abort to our loopcontrol effect

Browse Source
This commit is contained in:
Timothy Clem 2018-09-20 08:41:17 -07:00
parent 0341f21901
commit ceead75b69
2 changed files with 12 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,4 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, ScopedTypeVariables #-}
module Control.Abstract.Evaluator
( Evaluator(..)
-- * Effects
@ -9,6 +9,7 @@ module Control.Abstract.Evaluator
, LoopControl(..)
, throwBreak
, throwContinue
, throwAbort
, catchLoopControl
, runLoopControl
, module X
@ -59,6 +60,7 @@ runReturn = Eff.raiseHandler (fmap (either unReturn id) . runError)
data LoopControl address
= Break { unLoopControl :: address }
| Continue { unLoopControl :: address }
| Abort
deriving (Eq, Ord, Show)
throwBreak :: Member (Exc (LoopControl address)) effects
@ -71,6 +73,10 @@ throwContinue :: Member (Exc (LoopControl address)) effects
-> Evaluator address value effects address
throwContinue = throwError . Continue
throwAbort :: forall address effects value a . Member (Exc (LoopControl address)) effects
=> Evaluator address value effects a
throwAbort = throwError (Abort @address)
catchLoopControl :: (Member (Exc (LoopControl address)) effects, Effectful (m address value)) => m address value effects a -> (LoopControl address -> m address value effects a) -> m address value effects a
catchLoopControl = catchError

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

@ -14,7 +14,7 @@ module Data.Abstract.Value.Concrete
import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Boolean(..), Function(..), While(..))
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable (UnspecializedError)
import Data.Abstract.Evaluatable (UnspecializedError(..))
import Data.Abstract.Environment (Environment, Bindings, EvalContext(..))
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Name
@ -137,14 +137,14 @@ runWhile :: forall effects address body a .
runWhile = interpret $ \case
Abstract.While cond body -> loop $ \continue -> do
cond' <- runWhile (raiseEff cond)
-- let body' = interpose @(Resumable (BaseError (UnspecializedError (Value address body)))) (\(Resumable _) -> pure hole) $
-- runWhile (raiseEff body) *> continue
let body' = (runWhile (raiseEff body) *> continue) `catchError` (\_ -> pure unit)
-- let body' = runWhile (raiseEff body) *> continue
let body' = interpose @(Resumable (BaseError (UnspecializedError (Value address body)))) (\(Resumable (BaseError _ _ (UnspecializedError _))) -> throwAbort) $
runWhile (raiseEff body) *> continue
ifthenelse cond' body' (pure unit)
where
loop x = catchLoopControl (fix x) (\ control -> case control of
Break value -> deref 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.