From 4187810a1a1bd8f8ac67fdc5c6e06a5fbf8df68c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 21 Mar 2018 10:52:37 -0400 Subject: [PATCH 01/18] First stab at a prelude that enables subclassing. This appears to work, though the evaluation order in evaluatePreludedRubyFile is off somehow. --- preludes/ruby.rb | 9 +++++++++ src/Control/Abstract/Value.hs | 32 +++++++++++++++++++++----------- src/Data/Syntax/Declaration.hs | 3 ++- src/Semantic/Util.hs | 29 +++++++++++++++++++++++++++++ 4 files changed, 61 insertions(+), 12 deletions(-) create mode 100644 preludes/ruby.rb diff --git a/preludes/ruby.rb b/preludes/ruby.rb new file mode 100644 index 000000000..af3f8721d --- /dev/null +++ b/preludes/ruby.rb @@ -0,0 +1,9 @@ +class Object + def new + self + end + + def inspect + return "" + end +end diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 2bd15f435..bd95d5e0a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -87,7 +87,10 @@ class (Monad m, Show value) => MonadValue value m where ifthenelse :: value -> m a -> m a -> m a -- | Build a class value from a name and environment. - klass :: Name -> EnvironmentFor value -> m value + klass :: Name -- ^ The new class's identifier + -> Maybe value -- ^ A list of superclasses + -> EnvironmentFor value -- ^ The environment to capture + -> m value -- | Extract the environment from a class. objectEnvironment :: value -> m (EnvironmentFor value) @@ -152,7 +155,11 @@ instance ( Monad m multiple = pure . injValue . Value.Tuple array = pure . injValue . Value.Array - klass n = pure . injValue . Class n + klass n Nothing env = pure . injValue $ Class n env + klass n (Just super) env + | Just (Class _ superEnv) <- prjValue super = pure . injValue $ Class n (superEnv <> env) + | otherwise = fail ("Attempted to inherit from a non-class object: " <> show super) + objectEnvironment o | Just (Class _ env) <- prjValue o = pure env @@ -228,14 +235,16 @@ instance ( Monad m l <- label body injValue . Closure names l . Env.bind (foldr Set.delete (freeVariables body) names) <$> getEnv - apply op params = do - Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) - bindings <- foldr (\ (name, param) rest -> do - v <- param - a <- alloc name - assign a v - Env.insert name a <$> rest) (pure env) (zip names params) - localEnv (mappend bindings) (goto label >>= evaluateTerm) + apply op params + | Just klass@Class{} <- prjValue op = pure . injValue $ klass + | Just (Closure names label env) <- prjValue op = do + bindings <- foldr (\ (name, param) rest -> do + v <- param + a <- alloc name + assign a v + Env.insert name a <$> rest) (pure env) (zip names params) + localEnv (mappend bindings) (goto label >>= evaluateTerm) + | otherwise = fail ("Type error: expected class or closure") loop = fix @@ -260,7 +269,8 @@ instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, Mon rational _ = pure Type.Rational multiple = pure . Type.Product array = pure . Type.Array - klass _ _ = pure Object + + klass _ _ _ = pure Object objectEnvironment _ = pure mempty diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index f17fc4d07..fef446bc9 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -146,10 +146,11 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Class where eval Class{..} = do let name = freeVariable (subterm classIdentifier) + supers <- traverse subtermValue classSuperclasses (v, addr) <- letrec name $ do void $ subtermValue classBody classEnv <- Env.head <$> getEnv - klass name classEnv + klass name (listToMaybe supers) classEnv v <$ modifyEnv (Env.insert name addr) data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] } diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index a04782715..5301e0e7a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -22,6 +22,7 @@ import Data.Span import Data.Term import Diffing.Algorithm import Diffing.Interpreter +import qualified GHC.TypeLits as TypeLevel import Parsing.Parser import Prologue import Semantic @@ -31,9 +32,11 @@ import Semantic.Task import qualified Language.Go.Assignment as Go import qualified Language.Python.Assignment as Python import qualified Language.TypeScript.Assignment as TypeScript +import qualified Language.Ruby.Assignment as Ruby -- Ruby evaluateRubyFile = evaluateFile rubyParser +evaluatePreludedRubyFile = evaluateWithPrelude rubyParser evaluateRubyFiles = evaluateFiles rubyParser -- Go @@ -53,6 +56,15 @@ typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term evaluateTypeScriptFile = evaluateFile typescriptParser evaluateTypeScriptFiles = evaluateFiles typescriptParser +class HasPreludePath syntax where + type PreludePath syntax :: TypeLevel.Symbol + +instance HasPreludePath Ruby.Term where + type PreludePath Ruby.Term = "preludes/ruby.rb" + +instance HasPreludePath Python.Term where + type PreludePath Python.Term = "preludes/python.py" + -- Evalute a single file. evaluateFile :: forall term effects . ( Evaluatable (Base term) @@ -67,6 +79,23 @@ 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 paths = [TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)), path] + entry:xs <- traverse (parseFile parser) paths + pure $ evaluates @Value xs entry + -- Evaluate a list of files (head of file list is considered the entry point). evaluateFiles :: forall term effects . ( Evaluatable (Base term) From bf7f06a9f45a61100e21b4ea92a23515224412d8 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 21 Mar 2018 10:59:23 -0400 Subject: [PATCH 02/18] missing push --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index bd95d5e0a..8e952f48c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -157,7 +157,7 @@ instance ( Monad m klass n Nothing env = pure . injValue $ Class n env klass n (Just super) env - | Just (Class _ superEnv) <- prjValue super = pure . injValue $ Class n (superEnv <> env) + | Just (Class _ superEnv) <- prjValue super = pure . injValue $ Class n (Env.push superEnv <> env) | otherwise = fail ("Attempted to inherit from a non-class object: " <> show super) From b94d89fb74d6816fcf43811a52ee8b4fc88268dc Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 21 Mar 2018 11:11:48 -0400 Subject: [PATCH 03/18] lint --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8e952f48c..d79f20293 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -244,7 +244,7 @@ instance ( Monad m assign a v Env.insert name a <$> rest) (pure env) (zip names params) localEnv (mappend bindings) (goto label >>= evaluateTerm) - | otherwise = fail ("Type error: expected class or closure") + | otherwise = fail "Type error: expected class or closure" loop = fix From 91c6731921a0f476856ed0361247c7cfed2ac81c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 21 Mar 2018 17:21:59 -0400 Subject: [PATCH 04/18] add evaluateWith --- src/Analysis/Abstract/Evaluating.hs | 17 +++++++++++++++++ src/Semantic/Util.hs | 7 ++++--- 2 files changed, 21 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index cb89fea6a..585d51866 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -3,6 +3,7 @@ module Analysis.Abstract.Evaluating ( type Evaluating , evaluate , evaluates +, evaluateWith ) where import Control.Abstract.Evaluator @@ -39,6 +40,22 @@ 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 + preludeEnv <- evaluateModule prelude *> getEnv + withEnv 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) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 5301e0e7a..96ed35ca6 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -92,9 +92,10 @@ evaluateWithPrelude :: forall term effects -> FilePath -> IO (Final effects Value) evaluateWithPrelude parser path = do - let paths = [TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term)), path] - entry:xs <- traverse (parseFile parser) paths - pure $ evaluates @Value xs entry + 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 From 6f0f20deeaca2ebdeb0fbacba6ba15b468f489e2 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 22 Mar 2018 12:03:17 -0400 Subject: [PATCH 05/18] thread default environments properly throughout the stack --- preludes/python.py | 0 semantic.cabal | 1 + src/Analysis/Abstract/Evaluating.hs | 23 ++++++++++++++++++++--- src/Control/Abstract/Evaluator.hs | 6 ++++++ src/Language/Preluded.hs | 17 +++++++++++++++++ src/Semantic/Util.hs | 15 +++------------ 6 files changed, 47 insertions(+), 15 deletions(-) create mode 100644 preludes/python.py create mode 100644 src/Language/Preluded.hs diff --git a/preludes/python.py b/preludes/python.py new file mode 100644 index 000000000..e69de29bb diff --git a/semantic.cabal b/semantic.cabal index 132722e06..fae879c0f 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -108,6 +108,7 @@ library , Language.PHP.Assignment , Language.PHP.Grammar , Language.PHP.Syntax + , Language.Preluded , Language.Python.Assignment , Language.Python.Grammar , Language.Python.Syntax diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 585d51866..036d11a09 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -53,8 +53,14 @@ evaluateWith :: forall value term effects -> term -> Final effects value evaluateWith prelude t = runAnalysis @(Evaluating term value) $ do - preludeEnv <- evaluateModule prelude *> getEnv - withEnv preludeEnv (evaluateModule t) + -- 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 @@ -99,6 +105,7 @@ type EvaluatingEffects term value , 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 by evaluateModule , State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules , State (ExportsFor value) -- Exports (used to filter environments when they are imported) , State (IntMap.IntMap term) -- For jumps @@ -113,11 +120,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 @@ -152,4 +165,8 @@ instance ( Evaluatable (Base term) => MonadAnalysis term value (Evaluating term value effects) where type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value + evaluateModule t = do + def <- defaultEnvironment + withEnv def (evaluateTerm t) + analyzeTerm = eval diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index f7456094b..54dfae541 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -52,6 +52,12 @@ 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 + withDefaultEnvironment :: EnvironmentFor value -> m a -> m a + -- | Get the global export state. getExports :: m (ExportsFor value) -- | Set the global export state. diff --git a/src/Language/Preluded.hs b/src/Language/Preluded.hs new file mode 100644 index 000000000..1f3cf3f8a --- /dev/null +++ b/src/Language/Preluded.hs @@ -0,0 +1,17 @@ +module Language.Preluded + ( Preluded (..) + , export + ) 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" diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 96ed35ca6..bc073fd2f 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -23,6 +23,7 @@ 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 @@ -35,8 +36,7 @@ import qualified Language.TypeScript.Assignment as TypeScript import qualified Language.Ruby.Assignment as Ruby -- Ruby -evaluateRubyFile = evaluateFile rubyParser -evaluatePreludedRubyFile = evaluateWithPrelude rubyParser +evaluateRubyFile = evaluateWithPrelude rubyParser evaluateRubyFiles = evaluateFiles rubyParser -- Go @@ -45,7 +45,7 @@ evaluateGoFiles = evaluateFiles goParser typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule . snd <$> parseFile goParser path -- Python -evaluatePythonFile = evaluateFile pythonParser +evaluatePythonFile = evaluateWithPrelude pythonParser evaluatePythonFiles = evaluateFiles 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 @@ -56,15 +56,6 @@ typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term evaluateTypeScriptFile = evaluateFile typescriptParser evaluateTypeScriptFiles = evaluateFiles typescriptParser -class HasPreludePath syntax where - type PreludePath syntax :: TypeLevel.Symbol - -instance HasPreludePath Ruby.Term where - type PreludePath Ruby.Term = "preludes/ruby.rb" - -instance HasPreludePath Python.Term where - type PreludePath Python.Term = "preludes/python.py" - -- Evalute a single file. evaluateFile :: forall term effects . ( Evaluatable (Base term) From 3511aa1898620dcf0da0c15fb475051a9bb7a602 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 22 Mar 2018 12:09:10 -0400 Subject: [PATCH 06/18] add needed extensions --- src/Language/Preluded.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/Preluded.hs b/src/Language/Preluded.hs index 1f3cf3f8a..1a74ebe3a 100644 --- a/src/Language/Preluded.hs +++ b/src/Language/Preluded.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + module Language.Preluded ( Preluded (..) - , export ) where import GHC.TypeLits From d76033e50b54747a0379070d62559aebc34dd545 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 22 Mar 2018 12:15:16 -0400 Subject: [PATCH 07/18] fix unused import --- src/Semantic/Util.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index bc073fd2f..e80f16986 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -33,7 +33,6 @@ import Semantic.Task import qualified Language.Go.Assignment as Go import qualified Language.Python.Assignment as Python import qualified Language.TypeScript.Assignment as TypeScript -import qualified Language.Ruby.Assignment as Ruby -- Ruby evaluateRubyFile = evaluateWithPrelude rubyParser From 693045439a867b9a80c4dbd0a1e65b4dc9585e29 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 22 Mar 2018 13:02:39 -0400 Subject: [PATCH 08/18] Add test suite. --- src/Analysis/Abstract/Evaluating.hs | 33 +++++++++++++++++++------ src/Semantic/Util.hs | 20 ++++++++++++++- test/Analysis/Ruby/Spec.hs | 6 ++++- test/fixtures/ruby/analysis/preluded.rb | 5 ++++ 4 files changed, 55 insertions(+), 9 deletions(-) create mode 100644 test/fixtures/ruby/analysis/preluded.rb diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3c641b2b5..d9a0e6bd6 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,12 +1,13 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Evaluating -( type Evaluating -, evaluate -, evaluates -, evaluateWith -, require -, load -) where + ( type Evaluating + , evaluate + , evaluates + , evaluateWith + , evaluatesWith + , require + , load + ) where import Control.Abstract.Evaluator import Control.Monad.Effect @@ -82,6 +83,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) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ee619053d..15b4c6007 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -36,7 +36,7 @@ import qualified Language.TypeScript.Assignment as TypeScript -- Ruby evaluateRubyFile = evaluateWithPrelude rubyParser -evaluateRubyFiles = evaluateFiles rubyParser +evaluateRubyFiles = evaluateFilesWithPrelude rubyParser -- Go evaluateGoFile = evaluateFile goParser @@ -107,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 diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 52eab9fd2..8bb32c33b 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -30,12 +30,16 @@ spec = parallel $ do res <- evaluate' "subclass.rb" fst res `shouldBe` Right (injValue (String "\"\"")) + it "has prelude" $ do + res <- evaluate' "preluded.rb" + fst res `shouldBe` Right (injValue (String "\"\"")) + where addr = Address . Precise fixtures = "test/fixtures/ruby/analysis/" evaluate entry = snd <$> evaluate' entry evaluate' entry = fst . fst . fst . fst <$> - evaluateFiles rubyParser + evaluateFilesWithPrelude rubyParser [ fixtures <> entry , fixtures <> "foo.rb" ] diff --git a/test/fixtures/ruby/analysis/preluded.rb b/test/fixtures/ruby/analysis/preluded.rb new file mode 100644 index 000000000..6df3b1a59 --- /dev/null +++ b/test/fixtures/ruby/analysis/preluded.rb @@ -0,0 +1,5 @@ +class Foo < Object + def inspect + "" + end +end From 3e3ad4f078c676d8f5292dbc494b7e8b79123333 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 23 Mar 2018 11:25:05 -0400 Subject: [PATCH 09/18] very bad, no good hack to fix a lot of the tests --- src/Analysis/Abstract/Evaluating.hs | 6 +----- src/Control/Abstract/Evaluator.hs | 2 +- test/fixtures/ruby/analysis/preluded.rb | 2 ++ 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index d9a0e6bd6..c8146b289 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -93,7 +93,7 @@ evaluatesWith :: forall value term effects , Recursive term , Show (LocationFor value) ) - => term -- ^ Prelude to evaluate once + => 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 @@ -229,8 +229,4 @@ instance ( Evaluatable (Base term) => MonadAnalysis term value (Evaluating term value effects) where type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value - evaluateModule t = do - def <- defaultEnvironment - withEnv def (evaluateTerm t) - analyzeTerm = eval diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index ce1296bf8..f153c0f34 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -70,7 +70,7 @@ class Monad m => MonadEnvironment value m | m -> value where -- | Look a 'Name' up in the environment. 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) diff --git a/test/fixtures/ruby/analysis/preluded.rb b/test/fixtures/ruby/analysis/preluded.rb index 6df3b1a59..5b47f52af 100644 --- a/test/fixtures/ruby/analysis/preluded.rb +++ b/test/fixtures/ruby/analysis/preluded.rb @@ -3,3 +3,5 @@ class Foo < Object "" end end + +Foo.inspect() From 7f5460bdd162a9597bce24d0c7f6b2b5fcc29f69 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 23 Mar 2018 11:28:09 -0400 Subject: [PATCH 10/18] wrong infix operator --- src/Control/Abstract/Evaluator.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index f153c0f34..d1f250b22 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -6,6 +6,7 @@ module Control.Abstract.Evaluator , modifyExports , addExport , MonadHeap(..) + , fullEnvironment , modifyHeap , localize , lookupHeap @@ -68,9 +69,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) <|> (Env.lookup name <$> defaultEnvironment) + 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) @@ -98,6 +99,9 @@ modifyExports f = do addExport :: MonadEnvironment value m => Name -> Name -> Maybe (Address (LocationFor value) value) -> m () addExport name alias = modifyExports . Export.insert name alias +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. @@ -111,6 +115,7 @@ modifyHeap f = do s <- getHeap putHeap $! f s + -- | Look up the cell for the given 'Address' in the 'Heap'. lookupHeap :: (MonadHeap value m, Ord (LocationFor value)) => Address (LocationFor value) value -> m (Maybe (CellFor value)) lookupHeap = flip fmap getHeap . heapLookup From dce0f5c2771923831512f67297b2afc2c6a42f3a Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 23 Mar 2018 11:50:53 -0400 Subject: [PATCH 11/18] fix the specs --- test/Analysis/Ruby/Spec.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 8bb32c33b..009b0108c 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -13,18 +13,20 @@ spec = parallel $ do describe "evalutes Ruby" $ do it "require_relative" $ do env <- evaluate "main.rb" - let expectedEnv = [ (qualifiedName ["foo"], addr 0) ] + let expectedEnv = [ (qualifiedName ["Object"], addr 0) + , (qualifiedName ["foo"], addr 3)] env `shouldBe` expectedEnv it "load" $ do env <- evaluate "load.rb" - let expectedEnv = [ (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" fst res `shouldBe` Left "free variable: \"foo\"" - snd res `shouldBe` [] + snd res `shouldBe` [(qualifiedName ["Object"], addr 0)] it "subclass" $ do res <- evaluate' "subclass.rb" @@ -32,7 +34,7 @@ spec = parallel $ do it "has prelude" $ do res <- evaluate' "preluded.rb" - fst res `shouldBe` Right (injValue (String "\"\"")) + fst res `shouldBe` Right (injValue (String "\"\"")) where addr = Address . Precise From de15e436d09567deb19b9928804a13dda034f295 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 23 Mar 2018 14:39:13 -0400 Subject: [PATCH 12/18] fix otiose changes and add a comment --- src/Control/Abstract/Evaluator.hs | 2 ++ src/Control/Abstract/Value.hs | 17 ++++++++--------- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index d1f250b22..13c5a0bdd 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -99,6 +99,8 @@ 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 diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index cb71cbeb8..3f1533575 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -235,15 +235,14 @@ instance ( Monad m l <- label body injValue . Closure names l . Env.bind (foldr Set.delete (freeVariables body) names) <$> getEnv - apply op params - | Just (Closure names label env) <- prjValue op = do - bindings <- foldr (\ (name, param) rest -> do - v <- param - a <- alloc name - assign a v - Env.insert name a <$> rest) (pure env) (zip names params) - localEnv (mappend bindings) (goto label >>= evaluateTerm) - | otherwise = fail "Type error: expected class or closure" + apply op params = do + Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) + bindings <- foldr (\ (name, param) rest -> do + v <- param + a <- alloc name + assign a v + Env.insert name a <$> rest) (pure env) (zip names params) + localEnv (mappend bindings) (goto label >>= evaluateTerm) loop = fix From 4ab2d17b5ef87cc0f3e6321c7cc7df99e304a19f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 23 Mar 2018 14:39:57 -0400 Subject: [PATCH 13/18] stray whitespace --- src/Control/Abstract/Evaluator.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 13c5a0bdd..422e2066b 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -117,7 +117,6 @@ modifyHeap f = do s <- getHeap putHeap $! f s - -- | Look up the cell for the given 'Address' in the 'Heap'. lookupHeap :: (MonadHeap value m, Ord (LocationFor value)) => Address (LocationFor value) value -> m (Maybe (CellFor value)) lookupHeap = flip fmap getHeap . heapLookup From a079efbf0ba7758aba9fcb1cf1d425eb44e974bf Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 23 Mar 2018 11:40:25 -0700 Subject: [PATCH 14/18] Free variables as a List (and only create a set when needed) --- src/Analysis/CallGraph.hs | 13 ++++++------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/FreeVariables.hs | 15 +++++---------- src/Data/Syntax.hs | 3 +-- src/Language/PHP/Syntax.hs | 2 +- 5 files changed, 14 insertions(+), 21 deletions(-) diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 82e6d5385..0f09db29a 100644 --- a/src/Analysis/CallGraph.hs +++ b/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 diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 26b753b9c..06ab672f4 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -249,7 +249,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) diff --git a/src/Data/Abstract/FreeVariables.hs b/src/Data/Abstract/FreeVariables.hs index 266c9ca74..d2593d424 100644 --- a/src/Data/Abstract/FreeVariables.hs +++ b/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) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index d9b3f3917..cd22c7328 100644 --- a/src/Data/Syntax.hs +++ b/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] diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 5c9ef4908..5439ff6fd 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -363,7 +363,7 @@ 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" go [name] = letrec' name $ \addr -> subtermValue namespaceBody *> makeNamespace name addr From a44f9261fcfbe9d3e799d67cb96ff8489a4a5d2d Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 23 Mar 2018 14:40:33 -0400 Subject: [PATCH 15/18] ensure evaluatePythonFiles pulls in a prelude --- src/Semantic/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 15b4c6007..d7b39915e 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -45,7 +45,7 @@ typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluate -- Python evaluatePythonFile = evaluateWithPrelude pythonParser -evaluatePythonFiles = evaluateFiles 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 From 82bceec65811118d2c90280df3dd661ea506da99 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 23 Mar 2018 14:44:17 -0400 Subject: [PATCH 16/18] fix some comments --- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Control/Abstract/Evaluator.hs | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c8146b289..fbab7234d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -169,7 +169,7 @@ type EvaluatingEffects term value , 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 by evaluateModule + , 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 diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 422e2066b..ad6045afc 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -56,7 +56,8 @@ class Monad m => MonadEnvironment value m | m -> value where -- | Retrieve the default environment. defaultEnvironment :: m (EnvironmentFor value) - -- | Set the default environment for the lifetime of an action + -- | 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. From b1efc533cf78f4b7870f66363ba66b3211c7a602 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 23 Mar 2018 15:37:06 -0400 Subject: [PATCH 17/18] fix test --- test/Analysis/Ruby/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 387e7f14a..2151e412d 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -30,11 +30,11 @@ spec = parallel $ do it "subclass" $ do res <- evaluate' "subclass.rb" - join (fst res) `shouldBe` Right (injValue (String "\"\"")) + fst res `shouldBe` Right (Right (injValue (String "\"\""))) it "has prelude" $ do res <- evaluate' "preluded.rb" - fst res `shouldBe` Right (injValue (String "\"\"")) + fst res `shouldBe` Right (Right (injValue (String "\"\""))) where addr = Address . Precise From 690e839a5f9507f6f5f2dca2b4d29205215006c6 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 23 Mar 2018 15:10:49 -0700 Subject: [PATCH 18/18] Comments --- src/Language/PHP/Syntax.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 5439ff6fd..f092ad5a7 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -365,15 +365,20 @@ instance Evaluatable Namespace where where 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)