Merge pull request #2031 from github/module-exports

Add `HasPostlude` and `__semantic_export`

src/Control/Abstract/Primitive.hs

@@ -73,5 +73,13 @@ defineBuiltins :: ( AbstractValue address value effects
                   , Member Trace effects
                   )
                => Evaluator address value effects ()
-defineBuiltins =
+defineBuiltins = do
   define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit))
+
+  define "__semantic_export" (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))

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
@@ -108,11 +111,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
@@ -183,6 +188,35 @@ instance HasPrelude 'JavaScript where
     defineNamespace "console" $ do
       define "log" (lambda 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.

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
 

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

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