diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 6b9ec3df5..969a87a1b 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -79,3 +79,21 @@ builtInPrint :: ( AbstractValue address value effects ) => Evaluator address value effects value builtInPrint = lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit) + +builtInExport :: ( AbstractValue address value effects + , HasCallStack + , Member (Allocator address value) effects + , Member (Env address) effects + , Member Fresh effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects + , Member (Resumable (EnvironmentError address)) effects + ) + => Evaluator address value effects value +builtInExport = lambda (\ v -> do + var <- variable v >>= deref + (k, value) <- asPair var + sym <- asString k + addr <- box value + export (name sym) (name sym) (Just addr) + box unit) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 2697af8f9..dc0aa2c5f 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -6,6 +6,8 @@ module Data.Abstract.Evaluatable , traceResolve -- * Preludes , HasPrelude(..) +-- * Postludes +, HasPostlude(..) -- * Effects , EvalError(..) , throwEvalError @@ -63,7 +65,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where ) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef address)) eval expr = do - void $ traverse_ subtermValue expr + traverse_ subtermValue expr v <- throwResumable (Unspecialized ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")) rvalBox v @@ -75,6 +77,7 @@ evaluate :: ( AbstractValue address value inner , Evaluatable (Base term) , Foldable (Cell address) , FreeVariables term + , HasPostlude lang , HasPrelude lang , Member Fresh effects , Member (Modules address) effects @@ -107,11 +110,13 @@ evaluate lang analyzeModule analyzeTerm modules = do evaluated <- coerce (runInModule preludeEnv (moduleInfo m)) (analyzeModule (subtermRef . moduleBody) - (evalTerm <$> m)) + (evalModuleBody <$> m)) -- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module. local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest - evalTerm term = Subterm term (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term >>= TermEvaluator . address) + evalModuleBody term = Subterm term (do + result <- foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term >>= TermEvaluator . address + result <$ TermEvaluator (postlude lang)) runInModule preludeEnv info = runReader info @@ -168,6 +173,35 @@ instance HasPrelude 'JavaScript where defineNamespace "console" $ do define "log" builtInPrint +-- Postludes + +class HasPostlude (language :: Language) where + postlude :: ( AbstractValue address value effects + , HasCallStack + , Member (Allocator address value) effects + , Member (Env address) effects + , Member Fresh effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects + , Member (Resumable (EnvironmentError address)) effects + , Member Trace effects + ) + => proxy language + -> Evaluator address value effects () + postlude _ = pure () + +instance HasPostlude 'Go +instance HasPostlude 'Haskell +instance HasPostlude 'Java +instance HasPostlude 'PHP +instance HasPostlude 'Python +instance HasPostlude 'Ruby +instance HasPostlude 'TypeScript + +instance HasPostlude 'JavaScript where + postlude _ = trace "JS postlude" + + -- Effects -- | The type of error thrown when failing to evaluate a term. diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index a56d018b7..d4c4a4433 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -21,8 +21,9 @@ null :: Exports address -> Bool null = Map.null . unExports toBindings :: Exports address -> Bindings address -toBindings exports = unpairs (mapMaybe sequenceA (toList (unExports exports))) +toBindings = unpairs . mapMaybe sequenceA . toList . unExports +-- TODO: Should inserts overwrite an existing value for a given name? insert :: Name -> Name -> Maybe address -> Exports address -> Exports address insert name alias address = Exports . Map.insert name (alias, address) . unExports diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 84d42e080..63dab3f3a 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -29,7 +29,7 @@ module Parsing.Parser import Assigning.Assignment import qualified Assigning.Assignment.Deterministic as Deterministic import qualified CMarkGFM -import Data.Abstract.Evaluatable (HasPrelude) +import Data.Abstract.Evaluatable (HasPrelude, HasPostlude) import Data.AST import Data.Kind import Data.Language @@ -68,6 +68,7 @@ data SomeAnalysisParser typeclasses ann where SomeAnalysisParser :: ( ApplyAll' typeclasses fs , Element Syntax.Identifier fs , HasPrelude lang + , HasPostlude lang ) => Parser (Term (Sum fs) ann) -- ^ A parser. -> Proxy lang diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index b22f46e09..892abd6bb 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -108,6 +108,7 @@ runImportGraph :: forall effs lang term. , Evaluatable (Base term) , FreeVariables term , HasPrelude lang + , HasPostlude lang , Member Trace effs , Recursive term , Effects effs