diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 9ce302f65..f60919403 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -81,21 +81,19 @@ instance ( FreeVariables term ) => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where ret = FunctionC . const . ret - eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case + eff op = + let closure maybeName params body scope = do + packageInfo <- currentPackage + moduleInfo <- currentModule + Closure packageInfo moduleInfo maybeName params body scope <$> currentFrame + + in FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case Abstract.Function name params body scope k -> runEvaluator $ do - packageInfo <- currentPackage - moduleInfo <- currentModule - - currentFrame' <- currentFrame - let closure = Closure packageInfo moduleInfo (Just name) params (Right body) scope currentFrame' - Evaluator $ runFunctionC (k (Rval closure)) eval + val <- closure (Just name) params (Right body) scope + Evaluator $ runFunctionC (k $ Rval val) eval Abstract.BuiltIn associatedScope builtIn k -> runEvaluator $ do - packageInfo <- currentPackage - moduleInfo <- currentModule - - currentFrame' <- currentFrame - let closure = Closure packageInfo moduleInfo Nothing [] (Left builtIn) associatedScope currentFrame' - Evaluator $ runFunctionC (k closure) eval + val <- closure Nothing [] (Left builtIn) associatedScope + Evaluator $ runFunctionC (k val) eval Abstract.Call op params k -> runEvaluator $ do boxed <- case op of Closure _ _ _ _ (Left Print) _ _ -> traverse (trace . show) params *> rvalBox Unit diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index f1f9384ac..52cddcde8 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -556,14 +556,35 @@ instance Eq1 Module where liftEq = genericLiftEq instance Ord1 Module where liftCompare = genericLiftCompare instance Show1 Module where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable Module where - eval eval Module{..} = do - name <- maybeM (throwEvalError NoNameError) (declaredName moduleIdentifier) +declareModule :: ( AbstractValue term address value m + , Carrier sig m + , Declarations term + , Member (Allocator address) sig + , Member (Deref value) sig + , Member (Reader (CurrentFrame address)) sig + , Member (Reader (CurrentScope address)) sig + , Member (Reader Span) sig + , Member (Resumable (BaseError (EvalError address value))) sig + , Member (State (Heap address address value)) sig + , Member (State (ScopeGraph address)) sig + , Member Fresh sig + , Member (Reader ModuleInfo) sig + , Member (Resumable (BaseError (AddressError address value))) sig + , Member (Resumable (BaseError (HeapError address))) sig + , Member (Resumable (BaseError (ScopeError address))) sig + , Ord address + ) + => (term -> Evaluator term address value m (ValueRef address value)) + -> term + -> [term] + -> Evaluator term address value m (ValueRef address value) +declareModule eval identifier statements = do + name <- maybeM (throwEvalError NoNameError) (declaredName identifier) span <- ask @Span currentScope' <- currentScope let declaration = Declaration name - moduleBody = maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) (nonEmpty moduleStatements) + moduleBody = maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) (nonEmpty statements) maybeSlot <- maybeLookupDeclaration declaration case maybeSlot of @@ -590,6 +611,9 @@ instance Evaluatable Module where rvalBox unit +instance Evaluatable Module where + eval eval Module{..} = declareModule eval moduleIdentifier moduleStatements + instance Declarations1 Module where liftDeclaredName declaredName = declaredName . moduleIdentifier @@ -601,38 +625,8 @@ instance Ord1 InternalModule where liftCompare = genericLiftCompare instance Show1 InternalModule where liftShowsPrec = genericLiftShowsPrec instance Evaluatable InternalModule where - eval eval InternalModule{..} = do - name <- maybeM (throwEvalError NoNameError) (declaredName internalModuleIdentifier) - span <- ask @Span - currentScope' <- currentScope - - let declaration = Declaration name - moduleBody = maybe (rvalBox unit) (runApp . foldMap1 (App . eval)) (nonEmpty internalModuleStatements) - maybeSlot <- maybeLookupDeclaration declaration - - case maybeSlot of - Just slot -> do - moduleVal <- deref slot - maybeFrame <- scopedEnvironment moduleVal - case maybeFrame of - Just moduleFrame -> do - withScopeAndFrame moduleFrame moduleBody - Nothing -> throwEvalError (DerefError moduleVal) - Nothing -> do - let edges = Map.singleton Lexical [ currentScope' ] - childScope <- newScope edges - declare (Declaration name) span (Just childScope) - - currentFrame' <- currentFrame - let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame') - childFrame <- newFrame childScope frameEdges - - withScopeAndFrame childFrame (void moduleBody) - - moduleSlot <- lookupDeclaration (Declaration name) - assign moduleSlot =<< klass (Declaration name) childFrame - - rvalBox unit + eval eval InternalModule{..} = + declareModule eval internalModuleIdentifier internalModuleStatements instance Declarations a => Declarations (InternalModule a) where declaredName InternalModule{..} = declaredName internalModuleIdentifier