Merge pull request #1664 from github/preludes-and-subclassing

Implement language-specific preludes.

preludes/ruby.rb

@@ -0,0 +1,9 @@
+class Object
+  def new
+    self
+  end
+
+  def inspect
+    return "<object>"
+  end
+end

semantic.cabal

@@ -109,6 +109,7 @@ library
                      , Language.PHP.Assignment
                      , Language.PHP.Grammar
                      , Language.PHP.Syntax
+                     , Language.Preluded
                      , Language.Python.Assignment
                      , Language.Python.Grammar
                      , Language.Python.Syntax

src/Analysis/Abstract/Evaluating.hs

@@ -1,14 +1,16 @@
 {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.Evaluating
-( type Evaluating
-, evaluate
-, evaluates
-, findValue
-, findEnv
-, findHeap
-, require
-, load
-) where
+  ( type Evaluating
+  , evaluate
+  , evaluates
+  , evaluateWith
+  , evaluatesWith
+  , findValue
+  , findEnv
+  , findHeap
+  , require
+  , load
+  ) where
 
 import Control.Abstract.Evaluator
 import Control.Monad.Effect
@@ -47,6 +49,28 @@ evaluate :: forall value term effects
          -> Final effects value
 evaluate = runAnalysis @(Evaluating term value) . evaluateModule
 
+evaluateWith :: forall value term effects
+             .  ( effects ~ RequiredEffects term value (Evaluating term value effects)
+                , Evaluatable (Base term)
+                , FreeVariables term
+                , MonadAddressable (LocationFor value) value (Evaluating term value effects)
+                , MonadValue value (Evaluating term value effects)
+                , Recursive term
+                , Show (LocationFor value)
+                )
+         => term
+         -> term
+         -> Final effects value
+evaluateWith prelude t = runAnalysis @(Evaluating term value) $ do
+  -- evaluateTerm here rather than evaluateModule
+  -- TODO: we could add evaluatePrelude to MonadAnalysis as an alias for evaluateModule,
+  -- overridden in Evaluating to not reset the environment. In the future we'll want the
+  -- result of evaluating the Prelude to be a build artifact, rather than something that's
+  -- evaluated every single time, but that's contingent upon a whole lot of other future
+  -- scaffolding.
+  preludeEnv <- evaluateTerm prelude *> getEnv
+  withDefaultEnvironment preludeEnv (evaluateModule t)
+
 -- | Evaluate terms and an entry point to a value.
 evaluates :: forall value term effects
           .  ( effects ~ RequiredEffects term value (Evaluating term value effects)
@@ -62,6 +86,24 @@ evaluates :: forall value term effects
           -> Final effects value
 evaluates pairs (b, t) = runAnalysis @(Evaluating term value) (withModules b pairs (evaluateModule t))
 
+-- | Evaluate terms and an entry point to a value with a given prelude.
+evaluatesWith :: forall value term effects
+              .  ( effects ~ RequiredEffects term value (Evaluating term value effects)
+                 , Evaluatable (Base term)
+                 , FreeVariables term
+                 , MonadAddressable (LocationFor value) value (Evaluating term value effects)
+                 , MonadValue value (Evaluating term value effects)
+                 , Recursive term
+                 , Show (LocationFor value)
+                 )
+              => term           -- ^ Prelude to evaluate once
+              -> [(Blob, term)] -- ^ List of (blob, term) pairs that make up the program to be evaluated
+              -> (Blob, term)   -- ^ Entrypoint
+              -> Final effects value
+evaluatesWith prelude pairs (b, t)  = runAnalysis @(Evaluating term value) $ do
+  preludeEnv <- evaluateTerm prelude *> getEnv
+  withDefaultEnvironment preludeEnv (withModules b pairs (evaluateModule t))
+
 -- | Run an action with the passed ('Blob', @term@) pairs available for imports.
 withModules :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a
 withModules Blob{..} pairs = localModuleTable (const moduleTable)
@@ -128,12 +170,13 @@ deriving instance Member NonDet    effects => MonadNonDet (Evaluating term value
 type EvaluatingEffects term value
   = '[ Resumable Prelude.String value
      , Fail                                        -- Failure with an error message
-     , State  (EnvironmentFor value)               -- Environments (both local and global)
-     , State  (HeapFor value)                      -- The heap
-     , Reader (ModuleTable [term])                 -- Cache of unevaluated modules
+     , State  (EnvironmentFor value)                      -- Environments (both local and global)
+     , State  (HeapFor value)                             -- The heap
+     , Reader (ModuleTable [term])                        -- Cache of unevaluated modules
+     , Reader (EnvironmentFor value)                      -- Default environment used as a fallback in lookupEnv
      , State  (ModuleTable (EnvironmentFor value, value)) -- Cache of evaluated modules
-     , State  (ExportsFor value)                   -- Exports (used to filter environments when they are imported)
-     , State  (IntMap.IntMap term)                 -- For jumps
+     , State  (ExportsFor value)                          -- Exports (used to filter environments when they are imported)
+     , State  (IntMap.IntMap term)                        -- For jumps
      ]
 
 -- | Find the value in the 'Final' result of running.
@@ -164,11 +207,17 @@ instance Members '[Fail, State (IntMap.IntMap term)] effects => MonadControl ter
 
   goto label = IntMap.lookup label <$> raise get >>= maybe (fail ("unknown label: " <> show label)) pure
 
-instance Members '[State (ExportsFor value), State (EnvironmentFor value)] effects => MonadEnvironment value (Evaluating term value effects) where
+instance Members '[ State (ExportsFor value)
+                  , State (EnvironmentFor value)
+                  , Reader (EnvironmentFor value)
+                  ] effects => MonadEnvironment value (Evaluating term value effects) where
   getEnv = raise get
   putEnv = raise . put
   withEnv s = raise . localState s . lower
 
+  defaultEnvironment = raise ask
+  withDefaultEnvironment e = raise . local (const e) . lower
+
   getExports = raise get
   putExports = raise . put
   withExports s = raise . localState s . lower

src/Control/Abstract/Evaluator.hs

@@ -6,6 +6,7 @@ module Control.Abstract.Evaluator
   , modifyExports
   , addExport
   , MonadHeap(..)
+  , fullEnvironment
   , modifyHeap
   , localize
   , lookupHeap
@@ -53,6 +54,13 @@ class Monad m => MonadEnvironment value m | m -> value where
   -- | Sets the environment for the lifetime of the given action.
   withEnv :: EnvironmentFor value -> m a -> m a
 
+  -- | Retrieve the default environment.
+  defaultEnvironment :: m (EnvironmentFor value)
+
+  -- | Set the default environment for the lifetime of an action.
+  --   Usually only invoked in a top-level evaluation function.
+  withDefaultEnvironment :: EnvironmentFor value -> m a -> m a
+
   -- | Get the global export state.
   getExports :: m (ExportsFor value)
   -- | Set the global export state.
@@ -63,9 +71,9 @@ class Monad m => MonadEnvironment value m | m -> value where
   -- | Run an action with a locally-modified environment.
   localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a
 
-  -- | Look a 'Name' up in the environment.
+  -- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
   lookupEnv :: Name -> m (Maybe (Address (LocationFor value) value))
-  lookupEnv name = Env.lookup name <$> getEnv
+  lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
 
   -- | Look up a 'Name' in the environment, running an action with the resolved address (if any).
   lookupWith :: (Address (LocationFor value) value -> m value) -> Name -> m (Maybe value)
@@ -93,6 +101,11 @@ modifyExports f = do
 addExport :: MonadEnvironment value m => Name -> Name -> Maybe (Address (LocationFor value) value) -> m ()
 addExport name alias = modifyExports . Export.insert name alias
 
+-- | Obtain an environment that is the composition of the current and default environments.
+--   Useful for debugging.
+fullEnvironment :: MonadEnvironment value m => m (EnvironmentFor value)
+fullEnvironment = mappend <$> getEnv <*> defaultEnvironment
+
 -- | A 'Monad' abstracting a heap of values.
 class Monad m => MonadHeap value m | m -> value where
   -- | Retrieve the heap.

src/Language/Preluded.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE DataKinds, TypeFamilies #-}
+
+module Language.Preluded
+    ( Preluded (..)
+    ) where
+
+import GHC.TypeLits
+import qualified Language.Python.Assignment as Python
+import qualified Language.Ruby.Assignment as Ruby
+
+class Preluded syntax where
+  type PreludePath syntax :: Symbol
+
+instance Preluded Ruby.Term where
+  type PreludePath Ruby.Term = "preludes/ruby.rb"
+
+instance Preluded Python.Term where
+  type PreludePath Python.Term = "preludes/python.py"

src/Semantic/Util.hs

@@ -22,6 +22,8 @@ import Data.Span
 import Data.Term
 import Diffing.Algorithm
 import Diffing.Interpreter
+import qualified GHC.TypeLits as TypeLevel
+import Language.Preluded
 import Parsing.Parser
 import Prologue
 import Semantic
@@ -33,8 +35,8 @@ import qualified Language.Python.Assignment as Python
 import qualified Language.TypeScript.Assignment as TypeScript
 
 -- Ruby
-evaluateRubyFile = evaluateFile rubyParser
-evaluateRubyFiles = evaluateFiles rubyParser
+evaluateRubyFile = evaluateWithPrelude rubyParser
+evaluateRubyFiles = evaluateFilesWithPrelude rubyParser
 
 -- Go
 evaluateGoFile = evaluateFile goParser
@@ -42,8 +44,8 @@ evaluateGoFiles = evaluateFiles goParser
 typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . snd <$> parseFile goParser path
 
 -- Python
-evaluatePythonFile = evaluateFile pythonParser
-evaluatePythonFiles = evaluateFiles pythonParser
+evaluatePythonFile = evaluateWithPrelude pythonParser
+evaluatePythonFiles = evaluateFilesWithPrelude pythonParser
 typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path
 tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path
 evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path
@@ -71,6 +73,24 @@ evaluateFile :: forall term effects
              -> IO (Final effects Value)
 evaluateFile parser path = evaluate . snd <$> parseFile parser path
 
+evaluateWithPrelude :: forall term effects
+                    .  ( Evaluatable (Base term)
+                       , FreeVariables term
+                       , effects ~ RequiredEffects term Value (Evaluating term Value effects)
+                       , MonadAddressable Precise Value (Evaluating term Value effects)
+                       , MonadValue Value (Evaluating term Value effects)
+                       , Recursive term
+                       , TypeLevel.KnownSymbol (PreludePath term)
+                       )
+                    => Parser term
+                    -> FilePath
+                    -> IO (Final effects Value)
+evaluateWithPrelude parser path = do
+  let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
+  prelude <- parseFile parser preludePath
+  blob <- parseFile parser path
+  pure $ evaluateWith (snd prelude) (snd blob)
+
 -- Evaluate a list of files (head of file list is considered the entry point).
 evaluateFiles :: forall term effects
               .  ( Evaluatable (Base term)
@@ -87,6 +107,24 @@ evaluateFiles parser paths = do
   entry:xs <- traverse (parseFile parser) paths
   pure $ evaluates @Value xs entry
 
+evaluateFilesWithPrelude :: forall term effects
+                         .  ( Evaluatable (Base term)
+                            , FreeVariables term
+                            , effects ~ RequiredEffects term Value (Evaluating term Value effects)
+                            , MonadAddressable Precise Value (Evaluating term Value effects)
+                            , MonadValue Value (Evaluating term Value effects)
+                            , Recursive term
+                            , TypeLevel.KnownSymbol (PreludePath term)
+                            )
+                         => Parser term
+                         -> [FilePath]
+                         -> IO (Final effects Value)
+evaluateFilesWithPrelude parser paths = do
+  let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
+  prelude <- parseFile parser preludePath
+  entry:xs <- traverse (parseFile parser) paths
+  pure $ evaluatesWith @Value (snd prelude) xs entry
+
 -- Read and parse a file.
 parseFile :: Parser term -> FilePath -> IO (Blob, term)
 parseFile parser path = runTask $ do

test/Analysis/Ruby/Spec.hs

@@ -13,25 +13,33 @@ spec = parallel $ do
   describe "evalutes Ruby" $ do
     it "require_relative" $ do
       env <- findEnv <$> evaluate "main.rb"
-      env `shouldBe` [ (qualifiedName ["foo"], addr 0) ]
+      let expectedEnv = [ (qualifiedName ["Object"], addr 0)
+                        , (qualifiedName ["foo"], addr 3)]
+      env `shouldBe` expectedEnv
 
     it "load" $ do
       env <- findEnv <$> evaluate "load.rb"
-      env `shouldBe` [ (qualifiedName ["foo"], addr 0) ]
+      let expectedEnv = [ (qualifiedName ["Object"], addr 0)
+                        , (qualifiedName ["foo"], addr 3) ]
+      env `shouldBe` expectedEnv
 
     it "load wrap" $ do
       res <- evaluate "load-wrap.rb"
       findValue res `shouldBe` Left "free variable: \"foo\""
-      findEnv res `shouldBe` []
+      findEnv res `shouldBe` [(qualifiedName ["Object"], addr 0)]
 
     it "subclass" $ do
-      v <- findValue <$> evaluate "subclass.rb"
-      v `shouldBe` Right (Right (injValue (String "\"<bar>\"")))
+      res <- findValue <$> evaluate "subclass.rb"
+      res `shouldBe` Right (Right (injValue (String "\"<bar>\"")))
+
+    it "has prelude" $ do
+      res <- findValue <$> evaluate "preluded.rb"
+      res `shouldBe` Right (Right (injValue (String "\"<foo>\"")))
 
   where
     addr = Address . Precise
     fixtures = "test/fixtures/ruby/analysis/"
-    evaluate entry = evaluateFiles rubyParser
+    evaluate entry = evaluateFilesWithPrelude rubyParser
       [ fixtures <> entry
       , fixtures <> "foo.rb"
       ]

test/fixtures/ruby/analysis/preluded.rb

@@ -0,0 +1,7 @@
+class Foo < Object
+  def inspect
+    "<foo>"
+  end
+end
+
+Foo.inspect()