Merge branch 'master' into remove-fail

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

@@ -2,15 +2,17 @@
              StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 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
@@ -49,6 +51,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)
@@ -64,6 +88,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)
@@ -131,12 +173,13 @@ type EvaluatingEffects term value
   = '[ Resumable ValueExc
      , Resumable (Unspecialized 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.
@@ -171,11 +214,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/Analysis/CallGraph.hs

@@ -10,7 +10,6 @@ import qualified Algebra.Graph as G
 import Algebra.Graph.Class
 import Algebra.Graph.Export.Dot
 import Data.Abstract.FreeVariables
-import Data.Set (member)
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Declaration as Declaration
 import Data.Term
@@ -21,7 +20,7 @@ newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name }
   deriving (Eq, Graph, Show)
 
 -- | Build the 'CallGraph' for a 'Term' recursively.
-buildCallGraph :: (CallGraphAlgebra syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> Set Name -> CallGraph
+buildCallGraph :: (CallGraphAlgebra syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> [Name] -> CallGraph
 buildCallGraph = foldSubterms callGraphAlgebra
 
 
@@ -35,7 +34,7 @@ renderCallGraph = export (defaultStyle friendlyName) . unCallGraph
 --   This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
 class CallGraphAlgebra syntax where
   -- | A 'SubtermAlgebra' computing the 'CallGraph' for a piece of @syntax@.
-  callGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph
+  callGraphAlgebra :: FreeVariables term => syntax (Subterm term ([Name] -> CallGraph)) -> [Name] -> CallGraph
 
 instance (CallGraphAlgebraStrategy syntax ~ strategy, CallGraphAlgebraWithStrategy strategy syntax) => CallGraphAlgebra syntax where
   callGraphAlgebra = callGraphAlgebraWithStrategy (Proxy :: Proxy strategy)
@@ -43,7 +42,7 @@ instance (CallGraphAlgebraStrategy syntax ~ strategy, CallGraphAlgebraWithStrate
 
 -- | Types whose contribution to a 'CallGraph' is customized. If an instance’s definition is not being used, ensure that the type is mapped to 'Custom' in the 'CallGraphAlgebraStrategy'.
 class CustomCallGraphAlgebra syntax where
-  customCallGraphAlgebra :: FreeVariables term => syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph
+  customCallGraphAlgebra :: FreeVariables term => syntax (Subterm term ([Name] -> CallGraph)) -> [Name] -> CallGraph
 
 -- | 'Declaration.Function's produce a vertex for their name, with edges to any free variables in their body.
 instance CustomCallGraphAlgebra Declaration.Function where
@@ -56,8 +55,8 @@ instance CustomCallGraphAlgebra Declaration.Method where
 -- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'.
 instance CustomCallGraphAlgebra Syntax.Identifier where
   customCallGraphAlgebra (Syntax.Identifier name) bound
-    | name `member` bound = empty
-    | otherwise           = vertex name
+    | name `elem` bound = empty
+    | otherwise         = vertex name
 
 instance Apply CallGraphAlgebra syntaxes => CustomCallGraphAlgebra (Union syntaxes) where
   customCallGraphAlgebra = Prologue.apply (Proxy :: Proxy CallGraphAlgebra) callGraphAlgebra
@@ -68,7 +67,7 @@ instance CallGraphAlgebra syntax => CustomCallGraphAlgebra (TermF syntax a) wher
 
 -- | The mechanism selecting 'Default'/'Custom' implementations for 'callGraphAlgebra' depending on the @syntax@ type.
 class CallGraphAlgebraWithStrategy (strategy :: Strategy) syntax where
-  callGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term (Set Name -> CallGraph)) -> Set Name -> CallGraph
+  callGraphAlgebraWithStrategy :: FreeVariables term => proxy strategy -> syntax (Subterm term ([Name] -> CallGraph)) -> [Name] -> CallGraph
 
 -- | The 'Default' definition of 'callGraphAlgebra' combines all of the 'CallGraph's within the @syntax@ 'Monoid'ally.
 instance Foldable syntax => CallGraphAlgebraWithStrategy 'Default syntax where

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/Control/Abstract/Value.hs

@@ -281,7 +281,7 @@ instance ( Monad m
 
   abstract names (Subterm body _) = do
     l <- label body
-    injValue . Closure names l . Env.bind (foldr Set.delete (freeVariables body) names) <$> getEnv
+    injValue . Closure names l . Env.bind (foldr Set.delete (Set.fromList (freeVariables body)) names) <$> getEnv
 
   apply op params = do
     Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op)

src/Data/Abstract/FreeVariables.hs

@@ -30,7 +30,7 @@ type Label = Int
 -- | Types which can contain unbound variables.
 class FreeVariables term where
   -- | The set of free variables in the given value.
-  freeVariables :: term -> Set Name
+  freeVariables :: term -> [Name]
 
 
 -- | A lifting of 'FreeVariables' to type constructors of kind @* -> *@.
@@ -38,24 +38,19 @@ class FreeVariables term where
 --   'Foldable' types requiring no additional semantics to the set of free variables (e.g. types which do not bind any variables) can use (and even derive, with @-XDeriveAnyClass@) the default implementation.
 class FreeVariables1 syntax where
   -- | Lift a function mapping each element to its set of free variables through a containing structure, collecting the results into a single set.
-  liftFreeVariables :: (a -> Set Name) -> syntax a -> Set Name
-  default liftFreeVariables :: (Foldable syntax) => (a -> Set Name) -> syntax a -> Set Name
+  liftFreeVariables :: (a -> [Name]) -> syntax a -> [Name]
+  default liftFreeVariables :: (Foldable syntax) => (a -> [Name]) -> syntax a -> [Name]
   liftFreeVariables = foldMap
 
 -- | Lift the 'freeVariables' method through a containing structure.
-freeVariables1 :: (FreeVariables1 t, FreeVariables a) => t a -> Set Name
+freeVariables1 :: (FreeVariables1 t, FreeVariables a) => t a -> [Name]
 freeVariables1 = liftFreeVariables freeVariables
 
 freeVariable :: FreeVariables term => term -> Name
-freeVariable term = case toList (freeVariables term) of
+freeVariable term = case freeVariables term of
   [n] -> n
   xs -> Prelude.fail ("expected single free variable, but got: " <> show xs)
 
--- TODO: Need a dedicated concept of qualified names outside of freevariables (a
--- Set) b/c you can have something like `a.a.b.a`
--- qualifiedName :: FreeVariables term => term -> Name
--- qualifiedName term = let names = toList (freeVariables term) in B.intercalate "." names
-
 instance (FreeVariables1 syntax, Functor syntax) => FreeVariables (Term syntax ann) where
   freeVariables = cata (liftFreeVariables id)
 

src/Data/Syntax.hs

@@ -7,7 +7,6 @@ import Data.Abstract.Evaluatable
 import Data.AST
 import Data.Range
 import Data.Record
-import qualified Data.Set as Set
 import Data.Span
 import Data.Term
 import Diffing.Algorithm hiding (Empty)
@@ -111,7 +110,7 @@ instance Evaluatable Identifier where
   eval (Identifier name) = lookupWith deref name >>= maybe (fail ("free variable: " <> show (friendlyName name))) pure
 
 instance FreeVariables1 Identifier where
-  liftFreeVariables _ (Identifier x) = Set.singleton x
+  liftFreeVariables _ (Identifier x) = pure x
 
 
 newtype Program a = Program [a]

src/Language/PHP/Syntax.hs

@@ -363,17 +363,22 @@ instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Namespace where
   eval Namespace{..} = go names
     where
-      names = toList (freeVariables (subterm namespaceName))
+      names = freeVariables (subterm namespaceName)
       go [] = fail "expected at least one free variable in namespaceName, found none"
+      -- The last name creates a closure over the namespace body.
       go [name] = letrec' name $ \addr ->
         subtermValue namespaceBody *> makeNamespace name addr
+      -- Each namespace name creates a closure over the subsequent namespace closures
       go (name:xs) = letrec' name $ \addr ->
         go xs <* makeNamespace name addr
 
+      -- Make a namespace closure capturing the current environment.
       makeNamespace name addr = do
         namespaceEnv <- Env.head <$> getEnv
         v <- namespace name namespaceEnv
         v <$ assign addr v
+
+      -- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
       letrec' name body = do
         addr <- lookupOrAlloc name
         v <- localEnv id (body addr)

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 (Right (injValue (String "\"<bar>\""))))
+      res <- findValue <$> evaluate "subclass.rb"
+      res `shouldBe` Right (Right (Right (injValue (String "\"<bar>\""))))
+
+    it "has prelude" $ do
+      res <- findValue <$> evaluate "preluded.rb"
+      res `shouldBe` Right (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()