Merge pull request #1691 from github/less-fail

Compute "holes" in the import graph

semantic.cabal

@@ -15,7 +15,8 @@ library
   hs-source-dirs:      src
   exposed-modules:
                      -- Analyses & term annotations
-                       Analysis.Abstract.Caching
+                       Analysis.Abstract.BadVariables
+                     , Analysis.Abstract.Caching
                      , Analysis.Abstract.Collecting
                      , Analysis.Abstract.Dead
                      , Analysis.Abstract.Evaluating

src/Analysis/Abstract/BadVariables.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators #-}
+module Analysis.Abstract.BadVariables where
+
+import Control.Abstract.Analysis
+import Data.Abstract.Evaluatable
+import Prologue
+
+-- An analysis that resumes from evaluation errors and records the list of unresolved free variables.
+newtype BadVariables m term value (effects :: [* -> *]) a = BadVariables (m term value effects a)
+  deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
+
+deriving instance MonadControl term (m term value effects) => MonadControl term (BadVariables m term value effects)
+deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (BadVariables m term value effects)
+deriving instance MonadHeap value (m term value effects) => MonadHeap value (BadVariables m term value effects)
+deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (BadVariables m term value effects)
+deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (BadVariables m term value effects)
+
+instance ( Effectful (m term value)
+         , Member (Resumable (EvalError value)) effects
+         , Member (State [Name]) effects
+         , MonadAnalysis term value (m term value effects)
+         , MonadValue value (BadVariables m term value effects)
+         )
+      => MonadAnalysis term value (BadVariables m term value effects) where
+  type RequiredEffects term value (BadVariables m term value effects) = State [Name] ': RequiredEffects term value (m term value effects)
+
+  analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) (
+        \yield (FreeVariableError name) ->
+            raise (modify (name :)) >> unit >>= yield)
+
+  analyzeModule = liftAnalyze analyzeModule

src/Analysis/Abstract/Evaluating.hs

@@ -27,7 +27,9 @@ deriving instance Member NonDet    effects => MonadNonDet (Evaluating term value
 
 -- | Effects necessary for evaluating (whether concrete or abstract).
 type EvaluatingEffects term value
-  = '[ Resumable (ValueExc value)
+  = '[ Resumable (EvalError value)
+     , Resumable (LoadError term value)
+     , Resumable (ValueExc value)
      , Resumable (Unspecialized value)
      , Fail                                -- Failure with an error message
      , Reader [Module term]                -- The stack of currently-evaluating modules.

src/Analysis/Abstract/ImportGraph.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving,
+             TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.ImportGraph
 ( ImportGraph(..)
 , renderImportGraph
@@ -9,6 +10,7 @@ import qualified Algebra.Graph as G
 import           Algebra.Graph.Class
 import           Algebra.Graph.Export.Dot
 import           Control.Abstract.Analysis
+import           Data.Abstract.Evaluatable (LoadError (..))
 import           Data.Abstract.FreeVariables
 import           Data.Abstract.Module
 import           Prologue hiding (empty)
@@ -34,17 +36,29 @@ deriving instance MonadEvaluator term value (m term value effects) => MonadEvalu
 instance ( Effectful (m term value)
          , Member (State ImportGraph) effects
          , MonadAnalysis term value (m term value effects)
+         , Member (Resumable (LoadError term value)) effects
          )
          => MonadAnalysis term value (ImportGraphing m term value effects) where
   type RequiredEffects term value (ImportGraphing m term value effects) = State ImportGraph ': RequiredEffects term value (m term value effects)
 
-  analyzeTerm = liftAnalyze analyzeTerm
+  analyzeTerm eval term = resumeException
+                            @(LoadError term value)
+                            (liftAnalyze analyzeTerm eval term)
+                            (\yield (LoadError name) -> insertVertexName name >> yield [])
 
   analyzeModule recur m = do
+    insertVertexName (moduleName m)
+    liftAnalyze analyzeModule recur m
+
+insertVertexName :: (Effectful (m term value)
+                   , Member (State ImportGraph) effects
+                   , MonadEvaluator term value (m term value effects))
+                 => NonEmpty ByteString
+                 -> ImportGraphing m term value effects ()
+insertVertexName name = do
     ms <- askModuleStack
     let parent = maybe empty (vertex . moduleName) (listToMaybe ms)
-    modifyImportGraph (parent >< vertex (moduleName m) <>)
+    modifyImportGraph (parent >< vertex name <>)
-    liftAnalyze analyzeModule recur m
 
 (><) :: Graph a => a -> a -> a
 (><) = connect

src/Analysis/Abstract/Quiet.hs

@@ -2,7 +2,6 @@
 module Analysis.Abstract.Quiet where
 
 import Control.Abstract.Analysis
-import Control.Monad.Effect.Resumable
 import Data.Abstract.Evaluatable
 import Prologue
 

src/Control/Abstract/Analysis.hs

@@ -19,6 +19,7 @@ import qualified Control.Monad.Effect as Effect
 import Control.Monad.Effect.Fail as X
 import Control.Monad.Effect.Reader as X
 import Control.Monad.Effect.State as X
+import Control.Monad.Effect.Resumable as X
 import Data.Abstract.Module
 import Data.Coerce
 import Data.Type.Coercion

src/Control/Abstract/Value.hs

@@ -26,7 +26,7 @@ import Data.Abstract.Number as Number
 import Data.Scientific (Scientific)
 import Data.Semigroup.Reducer hiding (unit)
 import Prelude
-import Prologue
+import Prologue hiding (TypeError)
 
 -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP
 --   have built-in generalized-comparison ("spaceship") operators. If you want to
@@ -196,12 +196,16 @@ class ValueRoots value where
 
 -- The type of exceptions that can be thrown when constructing values in `MonadValue`.
 data ValueExc value resume where
-  ValueExc :: Prelude.String -> ValueExc value value
+  TypeError              :: Prelude.String -> ValueExc value value
-  StringExc :: Prelude.String -> ValueExc value ByteString
+  StringError            :: Prelude.String -> ValueExc value ByteString
+  NamespaceError         :: Prelude.String -> ValueExc value (EnvironmentFor value)
+  ScopedEnvironmentError :: Prelude.String -> ValueExc value (EnvironmentFor value)
 
 instance Eq1 (ValueExc value) where
-  liftEq _ (ValueExc a)  (ValueExc b)  = a == b
+  liftEq _ (TypeError a)  (TypeError b)                          = a == b
-  liftEq _ (StringExc a) (StringExc b) = a == b
+  liftEq _ (StringError a) (StringError b)                       = a == b
+  liftEq _ (NamespaceError a) (NamespaceError b)                 = a == b
+  liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b
   liftEq _ _             _                                       = False
 
 deriving instance Show (ValueExc value resume)

src/Data/Abstract/Evaluatable.hs

@@ -4,10 +4,13 @@ module Data.Abstract.Evaluatable
 , MonadEvaluatable
 , Evaluatable(..)
 , Unspecialized(..)
+, LoadError(..)
+, EvalError(..)
 , evaluateTerm
 , evaluateModule
 , withModules
 , evaluateModules
+, throwLoadError
 , require
 , load
 ) where
@@ -31,11 +34,41 @@ type MonadEvaluatable term value m =
   , MonadAddressable (LocationFor value) value m
   , MonadAnalysis term value m
   , MonadThrow (Unspecialized value) m
+  , MonadThrow (ValueExc value) m
+  , MonadThrow (LoadError term value) m
+  , MonadThrow (EvalError value) m
   , MonadValue value m
   , Recursive term
   , Show (LocationFor value)
   )
 
+
+-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
+data LoadError term value resume where
+  LoadError :: ModuleName -> LoadError term value [Module term]
+
+deriving instance Eq (LoadError term a b)
+deriving instance Show (LoadError term a b)
+instance Show1 (LoadError term value) where
+  liftShowsPrec _ _ = showsPrec
+instance Eq1 (LoadError term a) where
+  liftEq _ (LoadError a) (LoadError b) = a == b
+
+-- | The type of error thrown when failing to evaluate a term.
+data EvalError value resume where
+  -- Indicates we weren't able to dereference a name from the evaluated environment.
+  FreeVariableError :: Name -> EvalError value value
+
+deriving instance Eq (EvalError a b)
+deriving instance Show (EvalError a b)
+instance Show1 (EvalError value) where
+  liftShowsPrec _ _ = showsPrec
+instance Eq1 (EvalError term) where
+  liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b
+
+throwLoadError :: MonadEvaluatable term value m => LoadError term value resume -> m resume
+throwLoadError = throwException
+
 data Unspecialized a b where
   Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value
 
@@ -88,9 +121,9 @@ require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup nam
 load :: MonadEvaluatable term value m
      => ModuleName
      -> m (EnvironmentFor value, value)
-load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name
+load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache
   where
-    notFound = fail ("cannot load module: " <> show name)
+    notFound = throwLoadError (LoadError name)
 
     evalAndCache []     = (,) <$> pure mempty <*> unit
     evalAndCache [x]    = evalAndCache' x

src/Data/Abstract/Value.hs

@@ -9,7 +9,7 @@ import Data.Abstract.Evaluatable
 import qualified Data.Abstract.Number as Number
 import Data.Scientific (Scientific)
 import qualified Data.Set as Set
-import Prologue
+import Prologue hiding (TypeError)
 import Prelude hiding (Float, Integer, String, Rational, fail)
 import qualified Prelude
 
@@ -225,12 +225,12 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where
     pure (injValue (Namespace n (Env.mergeNewer env' env)))
     where asNamespaceEnv v
             | Just (Namespace _ env') <- prjValue v = pure env'
-            | otherwise                             = fail ("expected " <> show v <> " to be a namespace")
+            | otherwise                             = throwException $ NamespaceError ("expected " <> show v <> " to be a namespace")
 
   scopedEnvironment o
     | Just (Class _ env) <- prjValue o = pure env
     | Just (Namespace _ env) <- prjValue o = pure env
-    | otherwise = fail ("object type passed to scopedEnvironment doesn't have an environment: " <> show o)
+    | otherwise = throwException $ ScopedEnvironmentError ("object type passed to scopedEnvironment doesn't have an environment: " <> show o)
 
   asString v
     | Just (String n) <- prjValue v = pure n

src/Data/Syntax.hs

@@ -2,15 +2,14 @@
 {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
 module Data.Syntax where
 
-import Control.Monad.Fail
+import Data.Abstract.Evaluatable hiding (catchError)
-import Data.Abstract.Evaluatable
 import Data.AST
 import Data.Range
 import Data.Record
 import Data.Span
 import Data.Term
 import Diffing.Algorithm hiding (Empty)
-import Prelude hiding (fail)
+import Prelude
 import Prologue
 import qualified Assigning.Assignment as Assignment
 import qualified Data.Error as Error
@@ -107,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare
 instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Identifier where
-  eval (Identifier name) = lookupWith deref name >>= maybe (fail ("free variable: " <> show (friendlyName name))) pure
+  eval (Identifier name) = lookupWith deref name >>= maybe (throwException $ FreeVariableError name) pure
 
 instance FreeVariables1 Identifier where
   liftFreeVariables _ (Identifier x) = pure x

src/Semantic/Util.hs

@@ -3,9 +3,11 @@
 {-# OPTIONS_GHC -Wno-missing-signatures #-}
 module Semantic.Util where
 
+import Analysis.Abstract.BadVariables
 import Analysis.Abstract.Caching
 import Analysis.Abstract.Dead
 import Analysis.Abstract.Evaluating as X
+import Analysis.Abstract.ImportGraph
 import Analysis.Abstract.Tracing
 import Analysis.Declaration
 import Control.Abstract.Analysis
@@ -34,11 +36,14 @@ import System.FilePath.Posix
 
 import qualified Language.Go.Assignment as Go
 import qualified Language.Python.Assignment as Python
+import qualified Language.Ruby.Assignment as Ruby
 import qualified Language.TypeScript.Assignment as TypeScript
 
 -- Ruby
 evaluateRubyFile = evaluateWithPrelude rubyParser
 evaluateRubyFiles = evaluateFilesWithPrelude rubyParser
+evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing Evaluating Ruby.Term Value) . evaluateModules <$> parseFiles rubyParser paths
+evaluateRubyBadVariables paths = runAnalysis @(BadVariables Evaluating Ruby.Term Value) . evaluateModules <$> parseFiles rubyParser paths
 
 -- Go
 evaluateGoFile = evaluateFile goParser

test/Analysis/Python/Spec.hs

@@ -30,11 +30,11 @@ spec = parallel $ do
 
     it "subclasses" $ do
       v <- fst <$> evaluate "subclass.py"
-      v `shouldBe` Right (Right (Right (injValue (String "\"bar\""))))
+      v `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"bar\""))))))
 
     it "handles multiple inheritance left-to-right" $ do
       v <- fst <$> evaluate "multiple_inheritance.py"
-      v `shouldBe` Right (Right (Right (injValue (String "\"foo!\""))))
+      v `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"foo!\""))))))
 
   where
     addr = Address . Precise

test/Analysis/Ruby/Spec.hs

@@ -2,7 +2,10 @@
 
 module Analysis.Ruby.Spec (spec) where
 
+import Data.Abstract.Evaluatable (EvalError(..))
 import Data.Abstract.Value
+import Control.Monad.Effect (SomeExc(..))
+import Data.List.NonEmpty (NonEmpty(..))
 import Data.Map
 import Data.Map.Monoidal as Map
 
@@ -24,12 +27,12 @@ spec = parallel $ do
 
     it "evaluates load with wrapper" $ do
       res <- evaluate "load-wrap.rb"
-      fst res `shouldBe` Left "free variable: \"foo\""
+      fst res `shouldBe` Right (Right (Right (Right (Left (SomeExc (FreeVariableError ("foo" :| [])))))))
       environment (snd res) `shouldBe` [ (name "Object", addr 0) ]
 
     it "evaluates subclass" $ do
       res <- evaluate "subclass.rb"
-      fst res `shouldBe` Right (Right (Right (injValue (String "\"<bar>\""))))
+      fst res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<bar>\""))))))
       environment (snd res) `shouldBe` [ (name "Bar", addr 6)
                                        , (name "Foo", addr 3)
                                        , (name "Object", addr 0) ]
@@ -41,13 +44,13 @@ spec = parallel $ do
 
     it "evaluates modules" $ do
       res <- evaluate "modules.rb"
-      fst res `shouldBe` Right (Right (Right (injValue (String "\"<hello>\""))))
+      fst res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<hello>\""))))))
       environment (snd res) `shouldBe` [ (name "Object", addr 0)
                                        , (name "Bar", addr 3) ]
 
     it "has prelude" $ do
       res <- fst <$> evaluate "preluded.rb"
-      res `shouldBe` Right (Right (Right (injValue (String "\"<foo>\""))))
+      res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<foo>\""))))))
 
   where
     ns n = Just . Latest . Just . injValue . Namespace (name n)

test/fixtures/ruby/analysis/src/foo.rb

@@ -0,0 +1,3 @@
+def foo()
+  return "in foo"
+end