From 4187810a1a1bd8f8ac67fdc5c6e06a5fbf8df68c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 21 Mar 2018 10:52:37 -0400 Subject: [PATCH 01/16] 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/16] 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/16] 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/16] 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/16] 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/16] 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/16] 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/16] 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/16] 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/16] 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/16] 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/16] 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/16] 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 a44f9261fcfbe9d3e799d67cb96ff8489a4a5d2d Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 23 Mar 2018 14:40:33 -0400 Subject: [PATCH 14/16] 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 15/16] 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 16/16] 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