Fix terrible bug associated with environment comparisons being false

src/Analysis/Abstract/Caching.hs

@@ -92,8 +92,9 @@ convergingModules :: ( AbstractValue address value effects
 convergingModules recur m = do
   c <- getConfiguration (subterm (moduleBody m))
   -- Convergence here is predicated upon an Eq instance, not α-equivalence
-  cache <- converge lowerBound (\ prevCache -> isolateCache . raiseHandler locally $ do
+  cache <- converge lowerBound (\ prevCache -> isolateCache $ do
     TermEvaluator (putHeap (configurationHeap        c))
+    TermEvaluator (putEnv  (configurationEnvironment c))
     -- We need to reset fresh generation so that this invocation converges.
     resetFresh 0 $
     -- This is subtle: though the calling context supports nondeterminism, we want
@@ -102,8 +103,9 @@ convergingModules recur m = do
     -- would never complete). We don’t need to use the values, so we 'gather' the
     -- nondeterministic values into @()@.
       withOracle prevCache (gatherM (const ()) (recur m)))
-  TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
 
+  -- TODO: We're hitting an infinite loop here, c.f test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call
+  TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
 
 -- | Iterate a monadic action starting from some initial seed until the results converge.
 --

src/Analysis/Abstract/Graph.hs

@@ -49,7 +49,7 @@ graphingTerms :: ( Element Syntax.Identifier syntax
                  , Member (Reader ModuleInfo) effects
                  , Member (Env (Hole (Located address))) effects
                  , Member (State (Graph Vertex)) effects
-                 , term ~ Term (Sum syntax) ann
+                 , Base term ~ TermF (Sum syntax) ann
                  )
               => SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a)
               -> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a)

src/Control/Abstract/Environment.hs

@@ -3,6 +3,7 @@ module Control.Abstract.Environment
 ( Environment
 , Exports
 , getEnv
+, putEnv
 , export
 , lookupEnv
 , bind
@@ -29,6 +30,10 @@ import Prologue
 getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address)
 getEnv = send GetEnv
 
+-- | This is only for use in Analysis.Abstract.Caching.
+putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects ()
+putEnv = send . PutEnv
+
 -- | Add an export to the global export state.
 export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects ()
 export name alias addr = send (Export name alias addr)
@@ -67,6 +72,8 @@ data Env address return where
   Pop    ::                    Env address ()
   GetEnv ::                    Env address (Environment address)
   Export :: Name -> Name -> Maybe address -> Env address ()
+  PutEnv :: Environment address -> Env address ()
+
 
 handleEnv :: forall address effects value result
           .  ( Member (State (Environment address)) effects
@@ -81,6 +88,7 @@ handleEnv = \case
   Push -> modify (Env.push @address)
   Pop -> modify (Env.pop @address)
   GetEnv -> get
+  PutEnv e -> put e
   Export name alias addr -> modify (Exports.insert name alias addr)
 
 runEnv :: Environment address

src/Data/Abstract/Cache.hs

@@ -32,6 +32,8 @@ cacheSet key value = Cache . Monoidal.insert key value . unCache
 cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value
 cacheInsert = curry cons
 
+cacheKeys :: Cacheable term address cell value => Cache term address cell value -> [Configuration term address cell value]
+cacheKeys = Monoidal.keys . unCache
 
 instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where
   showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache

src/Data/Map/Monoidal.hs

@@ -8,6 +8,7 @@ module Data.Map.Monoidal
 , insert
 , filterWithKey
 , pairs
+, keys
 , module Reducer
 ) where
 
@@ -37,6 +38,8 @@ insert key value = Map . Map.insert key value . unMap
 filterWithKey :: (key -> value -> Bool) -> Map key value -> Map key value
 filterWithKey f = Map . Map.filterWithKey f . unMap
 
+keys :: Map key value -> [key]
+keys = map fst . pairs
 
 pairs :: Map key value -> [(key, value)]
 pairs = Map.toList . unMap

src/Semantic/Graph.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
 module Semantic.Graph
 ( runGraph
+, runCallGraph
 , runImportGraph
 , GraphType(..)
 , Graph
@@ -59,7 +60,7 @@ runGraph ImportGraph _ project
 runGraph CallGraph includePackages project
   | SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do
     package <- parsePackage parser project
-    modules <- runImportGraph lang package
+    modules <- topologicalSort <$> runImportGraph lang package
     runCallGraph lang includePackages modules package
 
 runCallGraph :: ( HasField ann Span
@@ -68,7 +69,10 @@ runCallGraph :: ( HasField ann Span
                 , Apply Ord1 syntax
                 , Apply Functor syntax
                 , Ord (Record ann)
-                , term ~ Term (Sum syntax) (Record ann)
+                , Show term
+                , Base term ~ TermF (Sum syntax) (Record ann)
+                , Ord term
+                , Corecursive term
                 , Declarations term
                 , Evaluatable (Base term)
                 , FreeVariables term
@@ -78,12 +82,12 @@ runCallGraph :: ( HasField ann Span
                 )
              => Proxy lang
              -> Bool
-             -> Graph (Module term)
+             -> [Module term]
              -> Package term
              -> Eff effs (Graph Vertex)
 runCallGraph lang includePackages modules package = do
   let analyzeTerm = withTermSpans . graphingTerms . cachingTerms
-      analyzeModule = (if includePackages then graphingPackages else id) . convergingModules
+      analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules
       extractGraph (((_, graph), _), _) = simplify graph
       runGraphAnalysis
         = run
@@ -106,7 +110,7 @@ runCallGraph lang includePackages modules package = do
         . fmap fst
         . runState (lowerBound @(ModuleTable (NonEmpty (Module (Hole (Located Monovariant), Environment (Hole (Located Monovariant)))))))
         . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
-  extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules))
+  extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules)
 
 
 runImportGraph :: ( Declarations term

src/Semantic/Util.hs

@@ -98,6 +98,16 @@ evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Lang
 
 typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go
 
+callGraphRubyProject paths = runTaskWithOptions debugOptions $ do
+  let proxy = Proxy @'Language.Ruby
+  let lang = Language.Ruby
+  blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths)
+  package <- parsePackage rubyParser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang [])
+  modules <- topologicalSort <$> runImportGraph proxy package
+  x <- runCallGraph proxy False modules package
+  pure (x, modules)
+
+
 -- Evaluate a project consisting of the listed paths.
 evaluateProject proxy parser lang paths = runTaskWithOptions debugOptions $ do
   blobs <- catMaybes <$> traverse readFile (flip File lang <$> paths)

test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/main.rb

@@ -0,0 +1,7 @@
+require './target'
+
+def go()
+  "done"
+end
+
+go()

test/fixtures/ruby/analysis/graphing/include-file-with-undefined-call/target.rb

@@ -0,0 +1,3 @@
+barf()
+
+def foo(); end