Merge remote-tracking branch 'origin/master' into java-assignment-continued

src/Control/Abstract/Primitive.hs

@@ -55,23 +55,45 @@ defineNamespace name scope = define name $ do
     Env.newEnv . Env.head <$> getEnv
   namespace name env
 
-lambda :: (AbstractFunction address value effects, Member Fresh effects)
+lambda :: ( AbstractFunction address value effects
+          , HasCallStack
+          , Member Fresh effects
+          , Member (Reader ModuleInfo) effects
+          , Member (Reader Span) effects
+          )
        => (Name -> Evaluator address value effects address)
        -> Evaluator address value effects value
-lambda body = do
+lambda body = withCurrentCallStack callStack $ do
   var <- gensym
   closure [var] lowerBound (body var)
 
-defineBuiltins :: ( 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
-                  )
-               => Evaluator address value effects ()
-defineBuiltins =
-  define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit))
+builtInPrint :: ( 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
+                )
+             => 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)

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
@@ -100,7 +103,6 @@ evaluate :: ( AbstractValue address value inner
          -> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (Environment address, address))))
 evaluate lang analyzeModule analyzeTerm modules = do
   (preludeEnv, _) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack $ do
-    defineBuiltins
     definePrelude lang
     box unit
   foldr (run preludeEnv) ask modules
@@ -108,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
@@ -148,27 +152,13 @@ instance HasPrelude 'Haskell
 instance HasPrelude 'Java
 instance HasPrelude 'PHP
 
-builtInPrint :: ( AbstractIntro value
-                , AbstractFunction address value effects
-                , Member (Allocator address value) effects
-                , Member (Env address) effects
-                , Member Fresh effects
-                , Member (Resumable (EnvironmentError address)) effects
-                )
-             => Name
-             -> Evaluator address value effects address
-builtInPrint v = do
-  print <- variable "__semantic_print" >>= deref
-  void $ call print [variable v]
-  box unit
-
 instance HasPrelude 'Python where
   definePrelude _ =
-    define "print" (lambda builtInPrint)
+    define "print" builtInPrint
 
 instance HasPrelude 'Ruby where
   definePrelude _ = do
-    define "puts" (lambda builtInPrint)
+    define "puts" builtInPrint
 
     defineClass "Object" [] $ do
       define "inspect" (lambda (const (box (string "<object>"))))
@@ -176,12 +166,41 @@ instance HasPrelude 'Ruby where
 instance HasPrelude 'TypeScript where
   definePrelude _ =
     defineNamespace "console" $ do
-      define "log" (lambda builtInPrint)
+      define "log" builtInPrint
 
 instance HasPrelude 'JavaScript where
   definePrelude _ = do
     defineNamespace "console" $ do
-      define "log" (lambda builtInPrint)
+      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
 

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

vendor/effects

@@ -1 +1 @@
-Subproject commit 105a543ccc98f2929cf0b1f1e97bcc48dfb8f718
+Subproject commit 0b6d04713b70e6b0551b841304fb44c9b1564e9b