From 2b54cf39538b01116d6562fcd6b9053436325aed Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 18 Apr 2018 13:59:31 -0400 Subject: [PATCH 01/12] Assign lshift --- src/Language/TypeScript/Assignment.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 7f633b3dd..04dd5c01b 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -234,8 +234,8 @@ assignmentExpression :: Assignment assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) <*> expression) augmentedAssignmentExpression :: Assignment -augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) expression [ - assign Expression.Plus <$ symbol AnonPlusEqual +augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) (term expression) [ + assign Expression.Plus <$ symbol AnonPlusEqual , assign Expression.Minus <$ symbol AnonMinusEqual , assign Expression.Times <$ symbol AnonStarEqual , assign Expression.DividedBy <$ symbol AnonSlashEqual @@ -244,6 +244,7 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi , assign Expression.BAnd <$ symbol AnonAmpersandEqual , assign Expression.RShift <$ symbol AnonRAngleRAngleEqual , assign Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngleEqual + , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual , assign Expression.BOr <$ symbol AnonPipeEqual ]) where assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Union Syntax Term assign c l r = inj (Statement.Assignment [] l (makeTerm1 (c l r))) From 1fcb16da32398ad1747b06893d62522602f282e1 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 18 Apr 2018 15:16:15 -0400 Subject: [PATCH 02/12] Add logging --- src/Analysis/Abstract/BadModuleResolutions.hs | 4 ++- src/Analysis/Abstract/BadValues.hs | 30 ++++++++++--------- src/Analysis/Abstract/BadVariables.hs | 18 ++++++----- src/Analysis/Abstract/ImportGraph.hs | 4 ++- src/Analysis/Abstract/Quiet.hs | 3 +- src/Data/Abstract/Evaluatable.hs | 1 + 6 files changed, 35 insertions(+), 25 deletions(-) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index d208fa9e1..127354cf3 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -26,7 +26,9 @@ instance ( Effectful m type Effects location term value (BadModuleResolutions m effects) = State [Name] ': Effects location term value (m effects) analyzeTerm eval term = resumeException @(ResolutionError value) (liftAnalyze analyzeTerm eval term) ( - \yield error -> case error of + \yield error -> do + traceM ("ResolutionError:" <> error) + case error of (RubyError nameToResolve) -> yield nameToResolve (TypeScriptError nameToResolve) -> yield nameToResolve) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 814925cf0..8a5efa31a 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -28,20 +28,22 @@ instance ( Effectful m type Effects location term value (BadValues m effects) = State [Name] ': Effects location term value (m effects) analyzeTerm eval term = resumeException @(ValueError location value) (liftAnalyze analyzeTerm eval term) ( - \yield error -> case error of - ScopedEnvironmentError{} -> do - env <- getEnv - yield (Env.push env) - CallError val -> yield val - StringError val -> yield (pack $ show val) - BoolError{} -> yield True - NumericError{} -> unit >>= yield - Numeric2Error{} -> unit >>= yield - ComparisonError{} -> unit >>= yield - NamespaceError{} -> getEnv >>= yield - BitwiseError{} -> unit >>= yield - Bitwise2Error{} -> unit >>= yield - KeyValueError{} -> unit >>= \x -> yield (x, x) + \yield error -> do + traceM ("ValueError" <> show error) + case error of + ScopedEnvironmentError{} -> do + env <- getEnv + yield (Env.push env) + CallError val -> yield val + StringError val -> yield (pack $ show val) + BoolError{} -> yield True + NumericError{} -> unit >>= yield + Numeric2Error{} -> unit >>= yield + ComparisonError{} -> unit >>= yield + NamespaceError{} -> getEnv >>= yield + BitwiseError{} -> unit >>= yield + Bitwise2Error{} -> unit >>= yield + KeyValueError{} -> unit >>= \x -> yield (x, x) ) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index fdaa81e74..0811d029c 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -27,13 +27,15 @@ instance ( Effectful m type Effects location term value (BadVariables m effects) = State [Name] ': Effects location term value (m effects) analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) ( - \yield err -> case err of - DefaultExportError{} -> yield () - ExportError{} -> yield () - IntegerFormatError{} -> yield 0 - FloatFormatError{} -> yield 0 - RationalFormatError{} -> yield 0 - FreeVariableError name -> raise (modify' (name :)) >> unit >>= yield - FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names)) + \yield err -> do + traceM ("EvalError" <> show err) + case err of + DefaultExportError{} -> yield () + ExportError{} -> yield () + IntegerFormatError{} -> yield 0 + FloatFormatError{} -> yield 0 + RationalFormatError{} -> yield 0 + FreeVariableError name -> raise (modify' (name :)) >> unit >>= yield + FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names)) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index bd9f0ca3a..010886721 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -71,11 +71,13 @@ instance ( Effectful m , Member Syntax.Identifier syntax , MonadAnalysis (Located location term) term value (m effects) , term ~ Term (Union syntax) ann + , Show ann ) => MonadAnalysis (Located location term) term value (ImportGraphing m effects) where type Effects (Located location term) term value (ImportGraphing m effects) = State ImportGraph ': Effects (Located location term) term value (m effects) - analyzeTerm eval term@(In _ syntax) = do + analyzeTerm eval term@(In ann syntax) = do + traceShowM ann case prj syntax of Just (Syntax.Identifier name) -> do moduleInclusion (Variable (unName name)) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index dc04ea439..9c68b1638 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -31,6 +31,7 @@ instance ( Effectful m => MonadAnalysis location term value (Quietly m effects) where type Effects location term value (Quietly m effects) = Effects location term value (m effects) - analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield) + analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield err@(Unspecialized _) -> + traceM ("Unspecialized:" <> show err) >> unit >>= yield) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 32adeeed1..59f641e3b 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -215,6 +215,7 @@ load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= eva modifyLoadStack (loadStackPush mPath) v <- trace ("load (evaluating): " <> show mPath) $ evaluateModule x modifyLoadStack loadStackPop + traceM ("load done:" <> show mPath) env <- filterEnv <$> getExports <*> getEnv modifyModuleTable (ModuleTable.insert name (env, v)) pure (env, v) From ffca89cebf7aa1075ef4e2caa7e424d2861baaae Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 18 Apr 2018 15:16:29 -0400 Subject: [PATCH 03/12] Add logging --- src/Language/TypeScript/Syntax.hs | 5 +++++ src/Semantic/Task.hs | 2 ++ 2 files changed, 7 insertions(+) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 126592b50..a07a040f4 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -108,6 +108,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec -- http://www.typescriptlang.org/docs/handbook/module-resolution.html instance Evaluatable Import where eval (Import symbols importPath) = do + traceM ("Evaluating Import" <> show importPath) modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions (importedEnv, _) <- isolate (require modulePath) modifyEnv (mappend (renamed importedEnv)) *> unit @@ -125,6 +126,7 @@ instance Show1 JavaScriptRequire where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JavaScriptRequire where eval (JavaScriptRequire aliasTerm importPath) = do + traceM ("Evaluating Require:" <> show importPath) modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) evalRequire modulePath alias @@ -139,6 +141,7 @@ instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedAliasedImport where eval (QualifiedAliasedImport aliasTerm importPath) = do + traceM ("Evaluating Aliased Import:" <> show importPath) modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) evalRequire modulePath alias @@ -152,6 +155,7 @@ instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SideEffectImport where eval (SideEffectImport importPath) = do + traceM ("Evaluating SideEffect Import:" <> show importPath) modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions void $ isolate (require modulePath) unit @@ -167,6 +171,7 @@ instance Show1 QualifiedExport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedExport where eval (QualifiedExport exportSymbols) = do + traceM ("Evaluating QualifiedExport:" <> show exportSymbols) -- Insert the aliases with no addresses. for_ exportSymbols $ \(name, alias) -> addExport name alias Nothing diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 308ddb1b5..c627b91e6 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -229,11 +229,13 @@ runParser blob@Blob{..} parser = case parser of time "parse.tree_sitter_ast_parse" languageTag $ IO.rethrowing (parseToAST language blob) AssignmentParser parser assignment -> do + traceM ("Parsing" <> blobPath) ast <- runParser blob parser `catchError` \ (SomeException err) -> do writeStat (Stat.increment "parse.parse_failures" languageTag) writeLog Error "failed parsing" (("task", "parse") : blobFields) throwError (toException err) options <- ask + traceM ("Assigning" <> blobPath) time "parse.assign" languageTag $ case Assignment.assign blobSource assignment ast of Left err -> do From 9d7038a53b0e1cec3763b9ef665bd55dc75ac7d6 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 18 Apr 2018 17:56:27 -0400 Subject: [PATCH 04/12] Yield maybes from scopedEnvironment, and values from ScopedEnvironmentErrors --- src/Analysis/Abstract/BadModuleResolutions.hs | 6 ++--- src/Analysis/Abstract/BadValues.hs | 7 ++---- src/Control/Abstract/Value.hs | 20 +++++++++------ src/Data/Abstract/Value.hs | 25 +++++++++++-------- src/Data/Syntax/Expression.hs | 5 ++-- src/Data/Syntax/Statement.hs | 5 ++-- src/Language/PHP/Syntax.hs | 10 +++++--- src/Language/Ruby/Syntax.hs | 5 ++-- 8 files changed, 47 insertions(+), 36 deletions(-) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 127354cf3..24ba082da 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -27,9 +27,9 @@ instance ( Effectful m analyzeTerm eval term = resumeException @(ResolutionError value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do - traceM ("ResolutionError:" <> error) + traceM ("ResolutionError:" <> show error) case error of - (RubyError nameToResolve) -> yield nameToResolve - (TypeScriptError nameToResolve) -> yield nameToResolve) + (RubyError nameToResolve) -> yield nameToResolve + (TypeScriptError nameToResolve) -> yield nameToResolve) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 8a5efa31a..0ca1de34a 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -4,7 +4,6 @@ module Analysis.Abstract.BadValues where import Control.Abstract.Analysis import Data.Abstract.Evaluatable import Analysis.Abstract.Evaluating -import Data.Abstract.Environment as Env import Prologue import Data.ByteString.Char8 (pack) @@ -31,16 +30,14 @@ instance ( Effectful m \yield error -> do traceM ("ValueError" <> show error) case error of - ScopedEnvironmentError{} -> do - env <- getEnv - yield (Env.push env) + ScopedEnvironmentError{} -> unit >>= yield CallError val -> yield val StringError val -> yield (pack $ show val) BoolError{} -> yield True NumericError{} -> unit >>= yield Numeric2Error{} -> unit >>= yield ComparisonError{} -> unit >>= yield - NamespaceError{} -> getEnv >>= yield + NamespaceError{} -> unit >>= yield BitwiseError{} -> unit >>= yield Bitwise2Error{} -> unit >>= yield KeyValueError{} -> unit >>= \x -> yield (x, x) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 03a7bd9b6..5315907e4 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-} module Control.Abstract.Value ( MonadValue(..) , Comparator(..) @@ -123,7 +123,7 @@ class (Monad m, Show value) => MonadValue location value m | m value -> location -> m value -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). - scopedEnvironment :: value -> m (Environment location value) + scopedEnvironment :: value -> m (Maybe (Environment location value)) -- | Evaluate an abstraction (a binder like a lambda or method definition). lambda :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value @@ -164,7 +164,8 @@ doWhile body cond = loop $ \ continue -> body *> do this <- cond ifthenelse this continue unit -makeNamespace :: ( MonadValue location value m +makeNamespace :: forall value location m. ( MonadValue location value m + , MonadThrow (ValueError location value) m , MonadEnvironment location value m , MonadHeap location value m , Ord location @@ -176,9 +177,12 @@ makeNamespace :: ( MonadValue location value m -> m value makeNamespace name addr supers = do superEnv <- mconcat <$> traverse scopedEnvironment supers - namespaceEnv <- Env.head <$> getEnv - v <- namespace name (Env.mergeNewer superEnv namespaceEnv) - v <$ assign addr v + case superEnv of + Just superEnv' -> do + namespaceEnv <- Env.head <$> getEnv + v <- namespace name (Env.mergeNewer superEnv' namespaceEnv) + v <$ assign addr v + Nothing -> throwException @(ValueError location value) $ NamespaceError (show name) -- | Value types, e.g. closures, which can root a set of addresses. @@ -191,8 +195,8 @@ class ValueRoots location value where data ValueError location value resume where StringError :: value -> ValueError location value ByteString BoolError :: value -> ValueError location value Bool - NamespaceError :: Prelude.String -> ValueError location value (Environment location value) - ScopedEnvironmentError :: Prelude.String -> ValueError location value (Environment location value) + NamespaceError :: Prelude.String -> ValueError location value value + ScopedEnvironmentError :: [value] -> ValueError location value value CallError :: value -> ValueError location value value NumericError :: value -> ValueError location value value Numeric2Error :: value -> value -> ValueError location value value diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index bdd4d5027..56a116f03 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -215,20 +215,25 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value klass n [] env = pure . injValue $ Class n env klass n supers env = do product <- mconcat <$> traverse scopedEnvironment supers - pure . injValue $ Class n (Env.push product <> env) + case product of + Just product' -> pure . injValue $ Class n (Env.push product' <> env) + Nothing -> throwValueError $ ScopedEnvironmentError supers + namespace n env = do maybeAddr <- lookupEnv n - env' <- maybe (pure mempty) (asNamespaceEnv <=< deref) maybeAddr - pure (injValue (Namespace n (Env.mergeNewer env' env))) - where asNamespaceEnv v - | Just (Namespace _ env') <- prjValue v = pure env' - | otherwise = throwException $ NamespaceError ("expected " <> show v <> " to be a namespace") + case maybeAddr of + Just address -> do + maybeVal <- prjValue <$> deref address + case maybeVal of + Just Namespace{..} -> pure (injValue (Namespace n (Env.mergeNewer namespaceScope env))) + val -> throwValueError $ NamespaceError ("expected " <> show val <> " to be a namespace") + Nothing -> Prologue.fail $ "expected address: " <> show n <> "to be in the environment" scopedEnvironment o - | Just (Class _ env) <- prjValue o = pure env - | Just (Namespace _ env) <- prjValue o = pure env - | otherwise = throwException $ ScopedEnvironmentError ("object type passed to scopedEnvironment doesn't have an environment: " <> show o) + | Just (Class _ env) <- prjValue o = pure (Just env) + | Just (Namespace _ env) <- prjValue o = pure (Just env) + | otherwise = throwValueError (ScopedEnvironmentError $ pure o) >> pure Nothing asString v | Just (String n) <- prjValue v = pure n @@ -251,7 +256,7 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value liftNumeric2 f left right | Just (Integer i, Integer j) <- prjPair pair = f i j & specialize - | Just (Integer i, Rational j) <- prjPair pair = f i j & specialize + | Just (Integer i, Rational j) <- prjPair pair = f i j & specialize | Just (Integer i, Float j) <- prjPair pair = f i j & specialize | Just (Rational i, Integer j) <- prjPair pair = f i j & specialize | Just (Rational i, Rational j) <- prjPair pair = f i j & specialize diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 03758a7dc..d4afbc55d 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -193,8 +193,9 @@ instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec instance Evaluatable MemberAccess where eval (fmap subtermValue -> MemberAccess mem acc) = do - lhs <- mem >>= scopedEnvironment - localEnv (mappend lhs) acc + mem' <- mem + lhs <- scopedEnvironment mem' + maybe (throwValueError . ScopedEnvironmentError $ pure mem') (flip localEnv acc . mappend) lhs -- | Subscript (e.g a[1]) data Subscript a diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index debd22cd8..9868053e2 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -103,8 +103,9 @@ instance Evaluatable Assignment where assign addr v modifyEnv (Env.insert name addr) $> v _ -> do - lhs <- subtermValue assignmentTarget >>= scopedEnvironment - localEnv (mappend lhs) (subtermValue assignmentValue) + target' <- subtermValue assignmentTarget + lhs <- scopedEnvironment target' + maybe (throwValueError . ScopedEnvironmentError $ pure target') (flip localEnv (subtermValue assignmentValue) . mappend) lhs -- | Post increment operator (e.g. 1++ in Go, or i++ in C). newtype PostIncrement a = PostIncrement a diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 088413995..b21a791e8 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -192,8 +192,9 @@ instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedName where eval (fmap subtermValue -> QualifiedName name iden) = do - lhs <- name >>= scopedEnvironment - localEnv (mappend lhs) iden + name' <- name + lhs <- scopedEnvironment name' + maybe (throwValueError . ScopedEnvironmentError $ pure name') (flip localEnv iden . mappend) lhs newtype NamespaceName a = NamespaceName (NonEmpty a) @@ -207,8 +208,9 @@ instance Evaluatable NamespaceName where eval (NamespaceName xs) = foldl1 f $ fmap subtermValue xs where f ns nam = do - env <- ns >>= scopedEnvironment - localEnv (mappend env) nam + ns' <- ns + env <- scopedEnvironment ns' + maybe (throwValueError . ScopedEnvironmentError $ pure ns') (flip localEnv nam . mappend) env newtype ConstDeclaration a = ConstDeclaration [a] deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 91e574b55..19fb1ae61 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -47,8 +47,9 @@ instance Evaluatable Send where func <- case sendReceiver of Just recv -> do - recvEnv <- subtermValue recv >>= scopedEnvironment - localEnv (mappend recvEnv) sel + val <- subtermValue recv + recvEnv <- scopedEnvironment val + maybe (throwValueError . ScopedEnvironmentError $ pure val) (flip localEnv sel . mappend) recvEnv Nothing -> sel -- TODO Does this require `localize` so we don't leak terms when resolving `sendSelector`? call func (map subtermValue sendArgs) -- TODO pass through sendBlock From d8e446f0a7914dff1e587160f2965eddded02063 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 19 Apr 2018 12:20:24 -0400 Subject: [PATCH 05/12] Add a hole value and don't run a condition if it depends on a hole --- src/Analysis/Abstract/BadValues.hs | 18 +++++++++--------- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Analysis/Abstract/Quiet.hs | 2 +- src/Control/Abstract/Value.hs | 5 +++++ src/Data/Abstract/Value.hs | 19 +++++++++++++++++-- 5 files changed, 33 insertions(+), 13 deletions(-) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 0ca1de34a..f93e63dc5 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -30,17 +30,17 @@ instance ( Effectful m \yield error -> do traceM ("ValueError" <> show error) case error of - ScopedEnvironmentError{} -> unit >>= yield + ScopedEnvironmentError{} -> hole >>= yield CallError val -> yield val StringError val -> yield (pack $ show val) - BoolError{} -> yield True - NumericError{} -> unit >>= yield - Numeric2Error{} -> unit >>= yield - ComparisonError{} -> unit >>= yield - NamespaceError{} -> unit >>= yield - BitwiseError{} -> unit >>= yield - Bitwise2Error{} -> unit >>= yield - KeyValueError{} -> unit >>= \x -> yield (x, x) + BoolError{} -> yield False + NumericError{} -> hole >>= yield + Numeric2Error{} -> hole >>= yield + ComparisonError{} -> hole >>= yield + NamespaceError{} -> hole >>= yield + BitwiseError{} -> hole >>= yield + Bitwise2Error{} -> hole >>= yield + KeyValueError{} -> hole >>= \x -> yield (x, x) ) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 0811d029c..bf697b9e2 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -35,7 +35,7 @@ instance ( Effectful m IntegerFormatError{} -> yield 0 FloatFormatError{} -> yield 0 RationalFormatError{} -> yield 0 - FreeVariableError name -> raise (modify' (name :)) >> unit >>= yield + FreeVariableError name -> raise (modify' (name :)) >> hole >>= yield FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names)) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 9c68b1638..bb2152288 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -32,6 +32,6 @@ instance ( Effectful m type Effects location term value (Quietly m effects) = Effects location term value (m effects) analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield err@(Unspecialized _) -> - traceM ("Unspecialized:" <> show err) >> unit >>= yield) + traceM ("Unspecialized:" <> show err) >> hole >>= yield) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 5315907e4..ad70a9f10 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -39,6 +39,9 @@ class (Monad m, Show value) => MonadValue location value m | m value -> location -- TODO: This might be the same as the empty tuple for some value types unit :: m value + -- | Construct an abstract hole. + hole :: m value + -- | Construct an abstract integral value. integer :: Prelude.Integer -> m value @@ -109,6 +112,8 @@ class (Monad m, Show value) => MonadValue location value m | m value -> location -- | Construct the nil/null datatype. null :: m value + isHole :: value -> m Bool + -- | Build a class value from a name and environment. klass :: Name -- ^ The new class's identifier -> [value] -- ^ A list of superclasses diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 56a116f03..3a7638508 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -28,6 +28,7 @@ type ValueConstructors location , Symbol , Tuple , Unit + , Hole ] -- | Open union of primitive values that terms can be evaluated to. @@ -67,6 +68,13 @@ instance Eq1 Unit where liftEq = genericLiftEq instance Ord1 Unit where liftCompare = genericLiftCompare instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec +data Hole value = Hole + deriving (Eq, Generic1, Ord, Show) + +instance Eq1 Hole where liftEq = genericLiftEq +instance Ord1 Hole where liftCompare = genericLiftCompare +instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec + -- | Boolean values. newtype Boolean value = Boolean Prelude.Bool deriving (Eq, Generic1, Ord, Show) @@ -191,6 +199,7 @@ instance Ord location => ValueRoots location (Value location) where -- | Construct a 'Value' wrapping the value arguments (if any). instance forall location term m. (Monad m, MonadEvaluatable location term (Value location) m) => MonadValue location (Value location) m where + hole = pure . injValue $ Hole unit = pure . injValue $ Unit integer = pure . injValue . Integer . Number.Integer boolean = pure . injValue . Boolean @@ -240,13 +249,19 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value | otherwise = throwException @(ValueError location (Value location)) $ StringError v ifthenelse cond if' else' = do - bool <- asBool cond - if bool then if' else else' + isHole <- isHole cond + if isHole then do + bool <- asBool cond + if bool then if' else else' + else + hole asBool val | Just (Boolean b) <- prjValue val = pure b | otherwise = throwException @(ValueError location (Value location)) $ BoolError val + isHole val = pure (prjValue val == Just Hole) + liftNumeric f arg | Just (Integer (Number.Integer i)) <- prjValue arg = integer $ f i From 04428df6bd583d4e64efc61957d71d60aeab91a7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 19 Apr 2018 13:12:51 -0400 Subject: [PATCH 06/12] Return holes from uninitialized address errors --- semantic.cabal | 1 + src/Analysis/Abstract/BadAddresses.hs | 34 +++++++++++++++++++++++++++ src/Analysis/Abstract/Evaluating.hs | 3 ++- src/Control/Abstract/Addressable.hs | 21 ++++++++++++++--- src/Data/Abstract/Evaluatable.hs | 1 + src/Semantic/Task.hs | 5 ++-- 6 files changed, 59 insertions(+), 6 deletions(-) create mode 100644 src/Analysis/Abstract/BadAddresses.hs diff --git a/semantic.cabal b/semantic.cabal index 2f63fabaa..1e359f98e 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -15,6 +15,7 @@ library hs-source-dirs: src exposed-modules: -- Analyses & term annotations + Analysis.Abstract.BadAddresses Analysis.Abstract.BadVariables Analysis.Abstract.BadValues Analysis.Abstract.BadModuleResolutions diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs new file mode 100644 index 000000000..01304eeb8 --- /dev/null +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +module Analysis.Abstract.BadAddresses where + +import Control.Abstract.Analysis +import Data.Abstract.Evaluatable +import Analysis.Abstract.Evaluating +import Prologue + +newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + +deriving instance MonadControl term (m effects) => MonadControl term (BadAddresses m effects) +deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadAddresses m effects) +deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadAddresses m effects) +deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadAddresses m effects) +deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadAddresses m effects) + +instance ( Effectful m + , Member (Resumable (AddressError location value)) effects + , Member (State (EvaluatingState location term value)) effects + , MonadAnalysis location term value (m effects) + , MonadValue location value (BadAddresses m effects) + , Show location + ) + => MonadAnalysis location term value (BadAddresses m effects) where + type Effects location term value (BadAddresses m effects) = Effects location term value (m effects) + + analyzeTerm eval term = resumeException @(AddressError location value) (liftAnalyze analyzeTerm eval term) ( + \yield error -> do + traceM ("AddressError:" <> show error) + case error of + (UninitializedAddress address) -> hole >>= yield) + + analyzeModule = liftAnalyze analyzeModule diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index aba745153..60c4fd876 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -32,7 +32,8 @@ deriving instance Member NonDet effects => Alternative (Evaluating location term -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects location term value - = '[ Resumable (EvalError value) + = '[ Resumable (AddressError location value) + , Resumable (EvalError value) , Resumable (ResolutionError value) , Resumable (LoadError term value) , Resumable (ValueError location value) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index c191ed97c..2c24067a5 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, GADTs #-} module Control.Abstract.Addressable where import Control.Abstract.Evaluator @@ -65,8 +65,8 @@ instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where allocLoc = pure . Monovariant -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized. -deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m, Show location) => Address location value -> m value -deref addr = lookupHeap addr >>= maybe (uninitializedAddress addr) (derefCell addr) +deref :: (MonadThrow (AddressError location value) m, MonadAddressable location m, MonadHeap location value m) => Address location value -> m value +deref addr = lookupHeap addr >>= maybe (throwAddressError $ UninitializedAddress addr) (derefCell addr) alloc :: MonadAddressable location m => Name -> m (Address location value) alloc = fmap Address . allocLoc @@ -74,3 +74,18 @@ alloc = fmap Address . allocLoc -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). uninitializedAddress :: (MonadFail m, Show location) => Address location value -> m a uninitializedAddress addr = fail $ "uninitialized address: " <> show addr + +data AddressError location value resume where + UninitializedAddress :: Address location value -> AddressError location value value + +deriving instance Eq location => Eq (AddressError location value resume) +deriving instance Show location => Show (AddressError location value resume) +instance Show location => Show1 (AddressError location value) where + liftShowsPrec _ _ = showsPrec +instance Eq location => Eq1 (AddressError location value) where + liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b + + +throwAddressError :: (MonadThrow (AddressError location value) m) => AddressError location value resume -> m resume +throwAddressError = throwException + diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 59f641e3b..5285199be 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -53,6 +53,7 @@ type MonadEvaluatable location term value m = , MonadThrow (LoadError term value) m , MonadThrow (EvalError value) m , MonadThrow (ResolutionError value) m + , MonadThrow (AddressError location value) m , MonadValue location value m , Recursive term , Reducer value (Cell location value) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index c627b91e6..0e5c9c4dd 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -47,6 +47,7 @@ module Semantic.Task , Telemetry ) where +import Analysis.Abstract.BadAddresses import Analysis.Abstract.BadModuleResolutions import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables @@ -139,7 +140,7 @@ render renderer = send . Render renderer type ImportGraphAnalysis term effects value = Abstract.ImportGraphing - (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term))))))) + (BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) effects value @@ -167,7 +168,7 @@ graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelu asAnalysisForTypeOfPackage = const extractGraph result = case result of - (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _)))))), _) -> pure $! graph + (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _))))))), _) -> pure $! graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) withPrelude Nothing a = a From 984cda99d0475b93862019da34522ce7072a6ddb Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 19 Apr 2018 13:35:45 -0400 Subject: [PATCH 07/12] Fix tests --- test/Analysis/Python/Spec.hs | 4 ++-- test/Analysis/Ruby/Spec.hs | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 25f037167..fa368af4f 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -37,11 +37,11 @@ spec = parallel $ do it "subclasses" $ do v <- fst <$> evaluate "subclass.py" - v `shouldBe` Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\"")))))))) + v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\""))))))))) it "handles multiple inheritance left-to-right" $ do v <- fst <$> evaluate "multiple_inheritance.py" - v `shouldBe` Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\"")))))))) + v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\""))))))))) where ns n = Just . Latest . Just . injValue . Namespace n diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 5d1e2e447..10719360a 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -27,12 +27,12 @@ spec = parallel $ do it "evaluates load with wrapper" $ do res <- evaluate "load-wrap.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo"))))))) + fst res `shouldBe` (Right (Right (Right (Right (Right (Right (Right []))))))) environment (snd res) `shouldBe` [ ("Object", addr 0) ] it "evaluates subclass" $ do res <- evaluate "subclass.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\""))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))) environment (snd res) `shouldBe` [ ("Bar", addr 6) , ("Foo", addr 3) , ("Object", addr 0) ] @@ -44,13 +44,13 @@ spec = parallel $ do it "evaluates modules" $ do res <- evaluate "modules.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\""))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))) environment (snd res) `shouldBe` [ ("Object", addr 0) , ("Bar", addr 3) ] it "has prelude" $ do res <- fst <$> evaluate "preluded.rb" - res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\""))))))) + res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))) where ns n = Just . Latest . Just . injValue . Namespace n From c8784ffab959232c5b671c5a676af47314d6f0d8 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 19 Apr 2018 13:45:39 -0400 Subject: [PATCH 08/12] Revert "Yield maybes from scopedEnvironment, and values from ScopedEnvironmentErrors" This reverts commit d09318a14143b80ae4e90a7192e94b0f9b512bd3. --- src/Analysis/Abstract/BadValues.hs | 9 ++++++--- src/Analysis/Abstract/Evaluating.hs | 4 ++-- src/Control/Abstract/Value.hs | 20 ++++++++------------ src/Data/Abstract/Value.hs | 25 ++++++++++--------------- src/Data/Syntax/Expression.hs | 5 ++--- src/Data/Syntax/Statement.hs | 5 ++--- src/Language/PHP/Syntax.hs | 10 ++++------ src/Language/Ruby/Syntax.hs | 5 ++--- test/Analysis/Ruby/Spec.hs | 2 +- test/Analysis/TypeScript/Spec.hs | 2 +- 10 files changed, 38 insertions(+), 49 deletions(-) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index f93e63dc5..3afbae34a 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -4,6 +4,7 @@ module Analysis.Abstract.BadValues where import Control.Abstract.Analysis import Data.Abstract.Evaluatable import Analysis.Abstract.Evaluating +import Data.Abstract.Environment as Env import Prologue import Data.ByteString.Char8 (pack) @@ -30,14 +31,16 @@ instance ( Effectful m \yield error -> do traceM ("ValueError" <> show error) case error of - ScopedEnvironmentError{} -> hole >>= yield + ScopedEnvironmentError{} -> do + env <- getEnv + yield (Env.push env) CallError val -> yield val StringError val -> yield (pack $ show val) - BoolError{} -> yield False + BoolError{} -> yield True NumericError{} -> hole >>= yield Numeric2Error{} -> hole >>= yield ComparisonError{} -> hole >>= yield - NamespaceError{} -> hole >>= yield + NamespaceError{} -> getEnv >>= yield BitwiseError{} -> hole >>= yield Bitwise2Error{} -> hole >>= yield KeyValueError{} -> hole >>= \x -> yield (x, x) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 60c4fd876..6afe6b223 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -32,12 +32,12 @@ deriving instance Member NonDet effects => Alternative (Evaluating location term -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects location term value - = '[ Resumable (AddressError location value) - , Resumable (EvalError value) + = '[ Resumable (EvalError value) , Resumable (ResolutionError value) , Resumable (LoadError term value) , Resumable (ValueError location value) , Resumable (Unspecialized value) + , Resumable (AddressError location value) , Fail -- Failure with an error message , Fresh -- For allocating new addresses and/or type variables. , Reader (SomeOrigin term) -- The current term’s origin. diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index ad70a9f10..94bc80d1c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-} module Control.Abstract.Value ( MonadValue(..) , Comparator(..) @@ -128,7 +128,7 @@ class (Monad m, Show value) => MonadValue location value m | m value -> location -> m value -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). - scopedEnvironment :: value -> m (Maybe (Environment location value)) + scopedEnvironment :: value -> m (Environment location value) -- | Evaluate an abstraction (a binder like a lambda or method definition). lambda :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value @@ -169,8 +169,7 @@ doWhile body cond = loop $ \ continue -> body *> do this <- cond ifthenelse this continue unit -makeNamespace :: forall value location m. ( MonadValue location value m - , MonadThrow (ValueError location value) m +makeNamespace :: ( MonadValue location value m , MonadEnvironment location value m , MonadHeap location value m , Ord location @@ -182,12 +181,9 @@ makeNamespace :: forall value location m. ( MonadValue location value m -> m value makeNamespace name addr supers = do superEnv <- mconcat <$> traverse scopedEnvironment supers - case superEnv of - Just superEnv' -> do - namespaceEnv <- Env.head <$> getEnv - v <- namespace name (Env.mergeNewer superEnv' namespaceEnv) - v <$ assign addr v - Nothing -> throwException @(ValueError location value) $ NamespaceError (show name) + namespaceEnv <- Env.head <$> getEnv + v <- namespace name (Env.mergeNewer superEnv namespaceEnv) + v <$ assign addr v -- | Value types, e.g. closures, which can root a set of addresses. @@ -200,8 +196,8 @@ class ValueRoots location value where data ValueError location value resume where StringError :: value -> ValueError location value ByteString BoolError :: value -> ValueError location value Bool - NamespaceError :: Prelude.String -> ValueError location value value - ScopedEnvironmentError :: [value] -> ValueError location value value + NamespaceError :: Prelude.String -> ValueError location value (Environment location value) + ScopedEnvironmentError :: Prelude.String -> ValueError location value (Environment location value) CallError :: value -> ValueError location value value NumericError :: value -> ValueError location value value Numeric2Error :: value -> value -> ValueError location value value diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 3a7638508..44dc346b5 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -224,25 +224,20 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value klass n [] env = pure . injValue $ Class n env klass n supers env = do product <- mconcat <$> traverse scopedEnvironment supers - case product of - Just product' -> pure . injValue $ Class n (Env.push product' <> env) - Nothing -> throwValueError $ ScopedEnvironmentError supers - + pure . injValue $ Class n (Env.push product <> env) namespace n env = do maybeAddr <- lookupEnv n - case maybeAddr of - Just address -> do - maybeVal <- prjValue <$> deref address - case maybeVal of - Just Namespace{..} -> pure (injValue (Namespace n (Env.mergeNewer namespaceScope env))) - val -> throwValueError $ NamespaceError ("expected " <> show val <> " to be a namespace") - Nothing -> Prologue.fail $ "expected address: " <> show n <> "to be in the environment" + env' <- maybe (pure mempty) (asNamespaceEnv <=< deref) maybeAddr + pure (injValue (Namespace n (Env.mergeNewer env' env))) + where asNamespaceEnv v + | Just (Namespace _ env') <- prjValue v = pure env' + | otherwise = throwException $ NamespaceError ("expected " <> show v <> " to be a namespace") scopedEnvironment o - | Just (Class _ env) <- prjValue o = pure (Just env) - | Just (Namespace _ env) <- prjValue o = pure (Just env) - | otherwise = throwValueError (ScopedEnvironmentError $ pure o) >> pure Nothing + | Just (Class _ env) <- prjValue o = pure env + | Just (Namespace _ env) <- prjValue o = pure env + | otherwise = throwException $ ScopedEnvironmentError ("object type passed to scopedEnvironment doesn't have an environment: " <> show o) asString v | Just (String n) <- prjValue v = pure n @@ -271,7 +266,7 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value liftNumeric2 f left right | Just (Integer i, Integer j) <- prjPair pair = f i j & specialize - | Just (Integer i, Rational j) <- prjPair pair = f i j & specialize + | Just (Integer i, Rational j) <- prjPair pair = f i j & specialize | Just (Integer i, Float j) <- prjPair pair = f i j & specialize | Just (Rational i, Integer j) <- prjPair pair = f i j & specialize | Just (Rational i, Rational j) <- prjPair pair = f i j & specialize diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index d4afbc55d..03758a7dc 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -193,9 +193,8 @@ instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec instance Evaluatable MemberAccess where eval (fmap subtermValue -> MemberAccess mem acc) = do - mem' <- mem - lhs <- scopedEnvironment mem' - maybe (throwValueError . ScopedEnvironmentError $ pure mem') (flip localEnv acc . mappend) lhs + lhs <- mem >>= scopedEnvironment + localEnv (mappend lhs) acc -- | Subscript (e.g a[1]) data Subscript a diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 9868053e2..debd22cd8 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -103,9 +103,8 @@ instance Evaluatable Assignment where assign addr v modifyEnv (Env.insert name addr) $> v _ -> do - target' <- subtermValue assignmentTarget - lhs <- scopedEnvironment target' - maybe (throwValueError . ScopedEnvironmentError $ pure target') (flip localEnv (subtermValue assignmentValue) . mappend) lhs + lhs <- subtermValue assignmentTarget >>= scopedEnvironment + localEnv (mappend lhs) (subtermValue assignmentValue) -- | Post increment operator (e.g. 1++ in Go, or i++ in C). newtype PostIncrement a = PostIncrement a diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index b21a791e8..088413995 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -192,9 +192,8 @@ instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedName where eval (fmap subtermValue -> QualifiedName name iden) = do - name' <- name - lhs <- scopedEnvironment name' - maybe (throwValueError . ScopedEnvironmentError $ pure name') (flip localEnv iden . mappend) lhs + lhs <- name >>= scopedEnvironment + localEnv (mappend lhs) iden newtype NamespaceName a = NamespaceName (NonEmpty a) @@ -208,9 +207,8 @@ instance Evaluatable NamespaceName where eval (NamespaceName xs) = foldl1 f $ fmap subtermValue xs where f ns nam = do - ns' <- ns - env <- scopedEnvironment ns' - maybe (throwValueError . ScopedEnvironmentError $ pure ns') (flip localEnv nam . mappend) env + env <- ns >>= scopedEnvironment + localEnv (mappend env) nam newtype ConstDeclaration a = ConstDeclaration [a] deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 19fb1ae61..91e574b55 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -47,9 +47,8 @@ instance Evaluatable Send where func <- case sendReceiver of Just recv -> do - val <- subtermValue recv - recvEnv <- scopedEnvironment val - maybe (throwValueError . ScopedEnvironmentError $ pure val) (flip localEnv sel . mappend) recvEnv + recvEnv <- subtermValue recv >>= scopedEnvironment + localEnv (mappend recvEnv) sel Nothing -> sel -- TODO Does this require `localize` so we don't leak terms when resolving `sendSelector`? call func (map subtermValue sendArgs) -- TODO pass through sendBlock diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 10719360a..ce590b749 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -27,7 +27,7 @@ spec = parallel $ do it "evaluates load with wrapper" $ do res <- evaluate "load-wrap.rb" - fst res `shouldBe` (Right (Right (Right (Right (Right (Right (Right []))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo")))))))) environment (snd res) `shouldBe` [ ("Object", addr 0) ] it "evaluates subclass" $ do diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 61729d58d..c455a78d2 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -30,7 +30,7 @@ spec = parallel $ do it "fails exporting symbols not defined in the module" $ do v <- fst <$> evaluate "bad-export.ts" - v `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc $ ExportError "foo.ts" (Name "pip"))))))) + v `shouldBe` Right (Right (Right (Right (Right (Right (Left (SomeExc $ ExportError "foo.ts" (Name "pip")))))))) where fixtures = "test/fixtures/typescript/analysis/" From 19a7e0e4bdfe9d8c50dce1495200ecf601629d2e Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 19 Apr 2018 13:52:50 -0400 Subject: [PATCH 09/12] appease hlint --- src/Analysis/Abstract/BadAddresses.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 01304eeb8..da926aefd 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -2,7 +2,6 @@ module Analysis.Abstract.BadAddresses where import Control.Abstract.Analysis -import Data.Abstract.Evaluatable import Analysis.Abstract.Evaluating import Prologue @@ -29,6 +28,6 @@ instance ( Effectful m \yield error -> do traceM ("AddressError:" <> show error) case error of - (UninitializedAddress address) -> hole >>= yield) + (UninitializedAddress _) -> hole >>= yield) analyzeModule = liftAnalyze analyzeModule From 26e6631e069b8318ec8b1bfaa74b90cee57c0c84 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 19 Apr 2018 13:59:21 -0400 Subject: [PATCH 10/12] Implement holes in types --- src/Data/Abstract/Type.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index a3014bd8f..3928f08c1 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -27,6 +27,7 @@ data Type | Hash [(Type, Type)] -- ^ Heterogenous key-value maps. | Object -- ^ Objects. Once we have some notion of inheritance we'll need to store a superclass. | Null -- ^ The null type. Unlike 'Unit', this unifies with any other type. + | Hole -- ^ The hole type. deriving (Eq, Ord, Show) -- TODO: À la carte representation of types. @@ -70,6 +71,7 @@ instance ( Alternative m ret <- localEnv (mappend env) body pure (Product tvars :-> ret) + hole = pure Hole unit = pure Unit integer _ = pure Int boolean _ = pure Bool @@ -93,6 +95,8 @@ instance ( Alternative m asPair _ = fail "Must evaluate to Value to use asPair" asBool _ = fail "Must evaluate to Value to use asBool" + isHole ty = pure (ty == Hole) + ifthenelse cond if' else' = unify cond Bool *> (if' <|> else') liftNumeric _ Float = pure Float From 126e5f594c0940ba5200502668d8196e84e63f6d Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 19 Apr 2018 14:06:45 -0400 Subject: [PATCH 11/12] Switch hole logic --- src/Data/Abstract/Value.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 44dc346b5..207c9fa6e 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -245,11 +245,11 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value ifthenelse cond if' else' = do isHole <- isHole cond - if isHole then do + if isHole then + hole + else do bool <- asBool cond if bool then if' else else' - else - hole asBool val | Just (Boolean b) <- prjValue val = pure b From 7d5daff1c000f6914d1d776fba06fe53f48d4db4 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 19 Apr 2018 15:54:17 -0400 Subject: [PATCH 12/12] Remove import logging --- src/Language/TypeScript/Syntax.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index a07a040f4..126592b50 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -108,7 +108,6 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec -- http://www.typescriptlang.org/docs/handbook/module-resolution.html instance Evaluatable Import where eval (Import symbols importPath) = do - traceM ("Evaluating Import" <> show importPath) modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions (importedEnv, _) <- isolate (require modulePath) modifyEnv (mappend (renamed importedEnv)) *> unit @@ -126,7 +125,6 @@ instance Show1 JavaScriptRequire where liftShowsPrec = genericLiftShowsPrec instance Evaluatable JavaScriptRequire where eval (JavaScriptRequire aliasTerm importPath) = do - traceM ("Evaluating Require:" <> show importPath) modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) evalRequire modulePath alias @@ -141,7 +139,6 @@ instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedAliasedImport where eval (QualifiedAliasedImport aliasTerm importPath) = do - traceM ("Evaluating Aliased Import:" <> show importPath) modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) evalRequire modulePath alias @@ -155,7 +152,6 @@ instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable SideEffectImport where eval (SideEffectImport importPath) = do - traceM ("Evaluating SideEffect Import:" <> show importPath) modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions void $ isolate (require modulePath) unit @@ -171,7 +167,6 @@ instance Show1 QualifiedExport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedExport where eval (QualifiedExport exportSymbols) = do - traceM ("Evaluating QualifiedExport:" <> show exportSymbols) -- Insert the aliases with no addresses. for_ exportSymbols $ \(name, alias) -> addExport name alias Nothing