diff --git a/src/Analysis/Abstract/Evaluating2.hs b/src/Analysis/Abstract/Evaluating2.hs index fa3347231..d646e11af 100644 --- a/src/Analysis/Abstract/Evaluating2.hs +++ b/src/Analysis/Abstract/Evaluating2.hs @@ -28,6 +28,7 @@ type Evaluating v = '[ Fail -- For 'MonadFail'. , State (Store (LocationFor v) v) -- For 'MonadStore'. -- , Reader (Environment (LocationFor v) v) -- For 'MonadEnv'. + , State (Environment (LocationFor v) v) -- , Reader (Live (LocationFor v) v) -- For 'MonadGC'. ] diff --git a/src/Data/Abstract/Eval2.hs b/src/Data/Abstract/Eval2.hs index e2eab430c..8dca4d2f2 100644 --- a/src/Data/Abstract/Eval2.hs +++ b/src/Data/Abstract/Eval2.hs @@ -7,8 +7,11 @@ module Data.Abstract.Eval2 , Recursive(..) , Base , Recur(..) +, Yield(..) ) where +import Control.Monad.Effect.Reader +import Control.Monad.Effect.State import Control.Monad.Effect.Env import Control.Monad.Effect.GC import Control.Monad.Fail @@ -18,19 +21,41 @@ import Data.Abstract.Value import Data.Functor.Classes import Data.Proxy import Data.Term +import Data.Monoid import Data.Union import Data.Functor.Foldable (Base, Recursive(..), project) import Prelude hiding (fail) import Control.Monad.Effect hiding (run) +import Debug.Trace + + +-- Yield with a modified environment +class Yield v m where + getEnv :: m (Environment (LocationFor v) v) + yield :: (Environment (LocationFor v) v -> Environment (LocationFor v) v) -> v -> m v + yield' :: (Environment (LocationFor v) v -> Environment (LocationFor v) v) -> m v -> m v + +instance (State (Environment (LocationFor v) v) :< fs) + => Yield v (Eff fs) where + getEnv = get + -- yield f v = local f (pure v) + -- yield' f v = local f v + yield f v = get >>= put . f >> pure v + yield' f v = get >>= put . f >> v + +-- | Recurse and evaluate a term class Recur term v m where recur :: term -> m v + recur' :: (Environment (LocationFor v) v -> Environment (LocationFor v) v) -> term -> m v instance ( Eval term v (Eff fs) (Base term) + , State (Environment (LocationFor v) v) :< fs , Recursive term ) => Recur term v (Eff fs) where recur = eval . project + recur' f term = get >>= put . f >> recur term -- | The 'Eval' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. @@ -61,14 +86,28 @@ instance ( Monad m -- , MonadEnv v m , AbstractValue v , Recursive t - -- , FreeVariables t + , FreeVariables t , Recur t v m + , Yield v m , Eval t v m (Base t) + + , Show (LocationFor v) ) => Eval t v m [] where eval [] = pure unit eval [x] = recur x - eval (x:xs) = recur @t @v x >> eval xs + eval (x:xs) = recur' @t @v ((bindEnv (freeVariables1 xs))) x >> eval xs + + -- eval (x:xs) = do + -- env <- askEnv :: m (Environment (LocationFor v) v) + -- recur' @t @v (bindEnv (freeVariables1 xs)) x >> eval xs + -- eval [x] = recur' id x + -- eval (x:xs) = recur @t @v x >> eval xs + -- eval (x:xs) = do + -- recur' @t @v ((bindEnv (freeVariables1 xs))) x >> eval xs + -- yield' (bindEnv (freeVariables1 xs)) (recur @t @v x >> eval xs) + -- recur @t @v x >> yield' (bindEnv (freeVariables1 xs)) (eval xs) + -- eval (x:xs) = eval (project x) >>= \_ -> eval xs -- eval ev yield [a] = ev pure a >>= yield diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index f5f106843..a3c2f5187 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -139,6 +139,15 @@ instance ( MonadAddress (LocationFor v) m env <- askEnv maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env) >>= yield +instance ( MonadAddress (LocationFor v) m + -- , MonadEnv v m + , MonadFail m + , MonadStore v m + , E2.Yield v m + ) => E2.Eval t v m Identifier where + eval (Identifier name) = do + env <- E2.getEnv + maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env) instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = point x @@ -184,11 +193,17 @@ instance ( Monad m eval ev yield (Program xs) = eval ev yield xs instance ( MonadFail m + -- , MonadEnv v m , Ord (LocationFor v) , AbstractValue v , E2.Recursive t , E2.Eval t v m (E2.Base t) + -- for [] instance of Eval , E2.Recur t v m + , FreeVariables t + , E2.Yield v m + + , Show (LocationFor v) ) => E2.Eval t v m Program where eval (Program xs) = E2.eval xs diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 11f4343a2..aeef750cf 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -10,6 +10,7 @@ import Data.Abstract.Address import Data.Abstract.Environment import Analysis.Abstract.Evaluating import Data.Abstract.Eval +import qualified Data.Abstract.Eval2 as E2 import Data.Abstract.FreeVariables import Data.Abstract.Type hiding (Type) import qualified Data.Abstract.Value as Value @@ -97,6 +98,26 @@ instance Show1 Method where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Method instance (MonadFail m) => Eval t v m Method +-- Evaluating a Function creates a closure and makes that value available in the +-- local environment. +instance ( Monad m + -- , MonadEnv (Value l t) m -- 'askEnv' + , FreeVariables t -- To get free variables from the function's parameters + , Semigroup (Cell l (Value l t)) -- envLookupOrAlloc' + , MonadStore (Value l t) m -- envLookupOrAlloc' + , MonadAddress l m -- envLookupOrAlloc' + , E2.Yield (Value l t) m -- 'yield' + ) => E2.Eval t (Value l t) m Method where + eval Method{..} = do + env <- E2.getEnv @(Value l t) + let params = toList (foldMap freeVariables methodParameters) + let v = inj (Closure params methodBody env) :: Value l t + (name, addr) <- envLookupOrAlloc' methodName env v + E2.yield (envInsert name addr) v + -- localEnv (envInsert name a) (yield v) + +instance ( MonadFail m + ) => E2.Eval t Type.Type m Method -- | A method signature in TypeScript or a method spec in Go. data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] } @@ -284,6 +305,8 @@ instance ( Monad m instance MonadFail m => Eval t Type.Type m Import +instance (MonadFail m) => E2.Eval t v m Import + -- | An imported symbol data ImportSymbol a = ImportSymbol { importSymbolName :: !a, importSymbolAlias :: !a } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)