Merge branch 'master' into publish-to-gpr

src/Analysis/Abstract/Caching.hs

@@ -105,7 +105,6 @@ convergingModules recur m = do
       withOracle prevCache (gatherM (const ()) (recur m)))
   TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
 
-
 -- | Iterate a monadic action starting from some initial seed until the results converge.
 --
 --   This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem

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

@@ -30,8 +30,8 @@ import Prologue
 getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address)
 getEnv = send GetEnv
 
--- | Replace the environment.
+-- | Replace the environment. This is only for use in Analysis.Abstract.Caching.
-putEnv :: Member (Env address) effects => (Environment address) -> Evaluator address value effects ()
+putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects ()
 putEnv = send . PutEnv
 
 -- | Add an export to the global export state.

src/Control/Abstract/Primitive.hs

@@ -55,31 +55,45 @@ defineNamespace name scope = define name $ do
     Env.newEnv . Env.head <$> getEnv
   namespace name env
 
-lambda :: (AbstractFunction address value effects, Member Fresh effects)
+lambda :: ( AbstractFunction address value effects
+          , HasCallStack
+          , Member Fresh effects
+          , Member (Reader ModuleInfo) effects
+          , Member (Reader Span) effects
+          )
        => (Name -> Evaluator address value effects address)
        -> Evaluator address value effects value
-lambda body = do
+lambda body = withCurrentCallStack callStack $ do
   var <- gensym
   closure [var] lowerBound (body var)
 
-defineBuiltins :: ( AbstractValue address value effects
+builtInPrint :: ( AbstractValue address value effects
-                  , HasCallStack
+                , HasCallStack
-                  , Member (Allocator address value) effects
+                , Member (Allocator address value) effects
-                  , Member (Env address) effects
+                , Member (Env address) effects
-                  , Member Fresh effects
+                , Member Fresh effects
-                  , Member (Reader ModuleInfo) effects
+                , Member (Reader ModuleInfo) effects
-                  , Member (Reader Span) effects
+                , Member (Reader Span) effects
-                  , Member (Resumable (EnvironmentError address)) effects
+                , Member (Resumable (EnvironmentError address)) effects
-                  , Member Trace effects
+                , Member Trace effects
-                  )
+                )
-               => Evaluator address value effects ()
+             => Evaluator address value effects value
-defineBuiltins = do
+builtInPrint = lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)
-  define "__semantic_print" (lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit))
 
-  define "__semantic_export" (lambda (\ v -> do
+builtInExport :: ( AbstractValue address value effects
-    var <- variable v >>= deref
+                 , HasCallStack
-    (k, value) <- asPair var
+                 , Member (Allocator address value) effects
-    sym <- asString k
+                 , Member (Env address) effects
-    addr <- box value
+                 , Member Fresh effects
-    export (name sym) (name sym) (Just addr)
+                 , Member (Reader ModuleInfo) effects
-    box unit))
+                 , Member (Reader Span) effects
+                 , Member (Resumable (EnvironmentError address)) effects
+                 )
+              => Evaluator address value effects value
+builtInExport = lambda (\ v -> do
+  var <- variable v >>= deref
+  (k, value) <- asPair var
+  sym <- asString k
+  addr <- box value
+  export (name sym) (name sym) (Just addr)
+  box unit)

src/Data/Abstract/Cache.hs

@@ -32,6 +32,9 @@ 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
 
+-- | Return all 'Configuration's in the provided cache.
+cacheKeys :: 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/Abstract/Environment.hs

@@ -151,5 +151,8 @@ addresses = fromAddresses . map snd . flatPairs
 
 instance Lower (Environment address) where lowerBound = Environment (lowerBound :| [])
 
+-- N.B. this show instance drops some information to avoid generating
+-- an infinite string in certain cases. As such, two unequal
+-- environments may produce equal outputs over Show.
 instance Show address => Show (Environment address) where
   showsPrec d = showsUnaryWith showsPrec "Environment" d . flatPairs

src/Data/Abstract/Evaluatable.hs

@@ -52,15 +52,15 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
           , Member (Env address) effects
           , Member (Exc (LoopControl address)) effects
           , Member (Exc (Return address)) effects
-          , Member Fresh effects
           , Member (Modules address) effects
           , Member (Reader ModuleInfo) effects
           , Member (Reader PackageInfo) effects
           , Member (Reader Span) effects
           , Member (Resumable (EnvironmentError address)) effects
+          , Member (Resumable (Unspecialized value)) effects
           , Member (Resumable EvalError) effects
           , Member (Resumable ResolutionError) effects
-          , Member (Resumable (Unspecialized value)) effects
+          , Member Fresh effects
           , Member Trace effects
           )
        => SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
@@ -103,7 +103,6 @@ evaluate :: ( AbstractValue address value inner
          -> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (Environment address, address))))
 evaluate lang analyzeModule analyzeTerm modules = do
   (preludeEnv, _) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack $ do
-    defineBuiltins
     definePrelude lang
     box unit
   foldr (run preludeEnv) ask modules
@@ -153,40 +152,26 @@ instance HasPrelude 'Haskell
 instance HasPrelude 'Java
 instance HasPrelude 'PHP
 
-builtInPrint :: ( AbstractIntro value
-                , AbstractFunction address value effects
-                , Member (Allocator address value) effects
-                , Member (Env address) effects
-                , Member Fresh effects
-                , Member (Resumable (EnvironmentError address)) effects
-                )
-             => Name
-             -> Evaluator address value effects address
-builtInPrint v = do
-  print <- variable "__semantic_print" >>= deref
-  void $ call print [variable v]
-  box unit
-
 instance HasPrelude 'Python where
   definePrelude _ =
-    define "print" (lambda builtInPrint)
+    define (name "print") builtInPrint
 
 instance HasPrelude 'Ruby where
   definePrelude _ = do
-    define "puts" (lambda builtInPrint)
+    define (name "puts") builtInPrint
 
-    defineClass "Object" [] $ do
+    defineClass (name "Object") [] $ do
-      define "inspect" (lambda (const (box (string "<object>"))))
+      define (name "inspect") (lambda (const (box (string "<object>"))))
 
 instance HasPrelude 'TypeScript where
   definePrelude _ =
-    defineNamespace "console" $ do
+    defineNamespace (name "console") $ do
-      define "log" (lambda builtInPrint)
+      define (name "log") builtInPrint
 
 instance HasPrelude 'JavaScript where
   definePrelude _ = do
-    defineNamespace "console" $ do
+    defineNamespace (name "console") $ do
-      define "log" (lambda builtInPrint)
+      define (name "log") builtInPrint
 
 -- Postludes
 

src/Data/Abstract/Name.hs

@@ -15,9 +15,8 @@ import qualified Data.Char as Char
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as LT
-import           Data.String
 import           Prologue
-import Proto3.Suite
+import           Proto3.Suite
 import qualified Proto3.Wire.Decode as Decode
 import qualified Proto3.Wire.Encode as Encode
 
@@ -32,7 +31,7 @@ instance HasDefault Name where
 
 instance Primitive Name where
   encodePrimitive num (Name text) = Encode.text num (LT.fromStrict text)
-  encodePrimitive num (I index) = Encode.int num index
+  encodePrimitive num (I index)   = Encode.int num index
   decodePrimitive = Name . LT.toStrict <$> Decode.text <|> I <$> Decode.int
   primType _ = Bytes
 
@@ -55,9 +54,6 @@ formatName (I i)       = Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ'
   where alphabet = ['a'..'z']
         (n, a) = i `divMod` length alphabet
 
-instance IsString Name where
-  fromString = Name . Text.pack
-
 -- $
 -- >>> I 0
 -- "_a"

src/Data/Abstract/Value/Abstract.hs

@@ -48,8 +48,8 @@ instance ( Member (Allocator address Abstract) effects
 instance ( Member (Allocator address Abstract) effects
          , Member (Env address) effects
          , Member (Exc (Return address)) effects
-         , Member Fresh effects
          , Member NonDet effects
+         , Member Fresh effects
          )
       => AbstractValue address Abstract effects where
   array _ = pure Abstract

src/Data/Abstract/Value/Type.hs

@@ -2,6 +2,7 @@
 module Data.Abstract.Value.Type
   ( Type (..)
   , TypeError (..)
+  , TypeMap
   , runTypes
   , runTypesWith
   , unify
@@ -108,6 +109,7 @@ runTypesWith :: ( Effectful m
              -> m effects a
 runTypesWith with = runTypeMap . runTypeErrorWith with
 
+-- TODO: change my name?
 newtype TypeMap = TypeMap { unTypeMap :: Map.Map TName Type }
 
 emptyTypeMap :: TypeMap

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/Data/Syntax/Declaration.hs

@@ -10,7 +10,7 @@ import           Prologue
 import           Proto3.Suite.Class
 
 data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
-  deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
+  deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, ToJSONFields1, Named1, Message1)
 
 instance Diffable Function where
   equivalentBySubterm = Just . functionName
@@ -33,6 +33,11 @@ instance Evaluatable Function where
 instance Declarations a => Declarations (Function a) where
   declaredName Function{..} = declaredName functionName
 
+instance Declarations1 Function where
+  liftDeclaredName declaredName Function{..} =
+    case declaredName functionName of
+      [] -> Nothing
+      (x:_) -> Just x
 
 data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a }
   deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)

src/Language/TypeScript/Syntax.hs

@@ -270,10 +270,10 @@ instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable DefaultExport where
   eval (DefaultExport term) = do
-    v <- subtermValue term
     case declaredName term of
       Just name -> do
         addr <- lookupOrAlloc name
+        v <- subtermValue term
         assign addr v
         export name name Nothing
         bind name addr

src/Semantic/Graph.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
 module Semantic.Graph
 ( runGraph
+, runCallGraph
 , runImportGraph
 , GraphType(..)
 , Graph
 , Vertex
-, GraphEff(..)
 , ImportGraphEff(..)
 , style
 , parsePackage
@@ -19,8 +19,11 @@ module Semantic.Graph
 , resumingEnvironmentError
 ) where
 
+
 import Prelude hiding (readFile)
 
+import           Analysis.Abstract.Caching
+import           Analysis.Abstract.Collecting
 import           Analysis.Abstract.Graph as Graph
 import           Control.Abstract
 import           Control.Monad.Effect (reinterpret)
@@ -29,14 +32,16 @@ import           Data.Abstract.Evaluatable
 import           Data.Abstract.Module
 import qualified Data.Abstract.ModuleTable as ModuleTable
 import           Data.Abstract.Package as Package
+import           Data.Abstract.Value.Type
 import           Data.Abstract.Value.Concrete (Value, ValueError (..), runValueErrorWith)
 import           Data.Graph
 import           Data.Project
 import           Data.Record
+import qualified Data.Syntax as Syntax
 import           Data.Term
 import           Data.Text (pack)
 import           Parsing.Parser
-import           Prologue hiding (MonadError (..))
+import           Prologue hiding (MonadError (..), TypeError (..))
 import           Semantic.Task as Task
 
 data GraphType = ImportGraph | CallGraph
@@ -55,52 +60,52 @@ 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
-    let analyzeTerm = withTermSpans . graphingTerms
+    runCallGraph lang includePackages modules package
-        analyzeModule = (if includePackages then graphingPackages else id) . graphingModules
+
-        extractGraph (_, (_, (graph, _))) = simplify graph
+runCallGraph :: ( HasField ann Span
-        runGraphAnalysis
+                , Element Syntax.Identifier syntax
-          = runState lowerBound
+                , Base term ~ TermF (Sum syntax) (Record ann)
-          . runFresh 0
+                , Ord term
-          . resumingLoadError
+                , Corecursive term
-          . resumingUnspecialized
+                , Declarations term
-          . resumingEnvironmentError
+                , Evaluatable (Base term)
-          . resumingEvalError
+                , FreeVariables term
-          . resumingResolutionError
+                , HasPrelude lang
-          . resumingAddressError
+                , HasPostlude lang
-          . resumingValueError
+                , Member Trace effs
-          . runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _ effs))
+                , Recursive term
-          . graphing
+                , Effects effs
-          . runReader (packageInfo package)
+                )
-          . runReader lowerBound
+             => Proxy lang
-          . runReader lowerBound
+             -> Bool
-          . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
+             -> [Module term]
-    extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules)))
+             -> 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 . graphingModules
+      extractGraph (_, (_, (graph, _))) = simplify graph
+      runGraphAnalysis
+        = runState (lowerBound @(Heap (Hole (Located Monovariant)) All Type))
+        . runFresh 0
+        . resumingLoadError
+        . resumingUnspecialized
+        . resumingEnvironmentError
+        . resumingEvalError
+        . resumingResolutionError
+        . resumingAddressError
+        . runTermEvaluator @_ @(Hole (Located Monovariant)) @Type
+        . graphing
+        . caching @[]
+        . resumingTypeError
+        . runReader (packageInfo package)
+        . runReader (lowerBound @Span)
+        . providingLiveSet
+        . runReader (lowerBound @(ModuleTable (NonEmpty (Module (Environment (Hole (Located Monovariant)), Hole (Located Monovariant))))))
+        . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
+  extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules))
 
--- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids.
-newtype GraphEff address outerEffects a = GraphEff
-  { runGraphEff :: Eff (  Exc (LoopControl address)
-                       ': Exc (Return address)
-                       ': Env address
-                       ': Allocator address (Value address (GraphEff address outerEffects))
-                       ': Reader ModuleInfo
-                       ': Modules address
-                       ': Reader (ModuleTable (NonEmpty (Module (Environment address, address))))
-                       ': Reader Span
-                       ': Reader PackageInfo
-                       ': State (Graph Vertex)
-                       ': Resumable (ValueError address (GraphEff address outerEffects))
-                       ': Resumable (AddressError address (Value address (GraphEff address outerEffects)))
-                       ': Resumable ResolutionError
-                       ': Resumable EvalError
-                       ': Resumable (EnvironmentError address)
-                       ': Resumable (Unspecialized (Value address (GraphEff address outerEffects)))
-                       ': Resumable (LoadError address)
-                       ': Fresh
-                       ': State (Heap address Latest (Value address (GraphEff address outerEffects)))
-                       ': outerEffects
-                       ) a
-  }
 
 
 runImportGraph :: forall effs lang term.
@@ -215,7 +220,7 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *
   IntegerFormatError{}     -> pure 0
   FloatFormatError{}       -> pure 0
   RationalFormatError{}    -> pure 0
-  FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
+  FreeVariablesError names -> pure (fromMaybeLast (name "unknown") names))
 
 resumingUnspecialized :: (Member Trace effects, AbstractHole value, Effects effects) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a
 resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> hole)
@@ -245,3 +250,14 @@ resumingEnvironmentError :: (AbstractHole address, Effects effects) => Evaluator
 resumingEnvironmentError
   = runState []
   . reinterpret (\ (Resumable (FreeVariable name)) -> modify' (name :) $> hole)
+
+resumingTypeError :: ( Alternative (m address Type (State TypeMap ': effects))
+                     , Effects effects
+                     , Effectful (m address Type)
+                     , Member Trace effects
+                     )
+                  => m address Type (Resumable TypeError ': State TypeMap ': effects) a
+                  -> m address Type effects a
+resumingTypeError = runTypesWith (\err -> trace ("TypeError " <> show err) *> case err of
+  UnificationError l r -> pure l <|> pure r
+  InfiniteType _ r -> pure r)

src/Semantic/Util.hs

@@ -102,6 +102,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 = withOptions debugOptions $ \ config logger statter ->
   evaluateProject' (TaskConfig config logger statter) proxy parser lang paths

test/Diffing/Algorithm/RWS/Spec.hs

@@ -12,8 +12,8 @@ import Data.Term
 import Data.These
 import Diffing.Algorithm
 import Diffing.Algorithm.RWS
-import Test.Hspec
 import Test.Hspec.LeanCheck
+import SpecHelpers
 
 spec :: Spec
 spec = parallel $ do

test/Diffing/Interpreter/Spec.hs

@@ -14,6 +14,7 @@ import Test.Hspec (Spec, describe, it, parallel)
 import Test.Hspec.Expectations.Pretty
 import Test.Hspec.LeanCheck
 import Test.LeanCheck.Core
+import SpecHelpers
 
 spec :: Spec
 spec = parallel $ do

test/SpecHelpers.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module SpecHelpers
 ( module X
 , runBuilder
@@ -44,6 +46,7 @@ import Data.Record as X
 import Data.Semilattice.Lower as X
 import Data.Source as X
 import Data.Span as X
+import Data.String
 import Data.Sum
 import Data.Term as X
 import Parsing.Parser as X
@@ -75,6 +78,11 @@ import Control.Exception (displayException)
 
 runBuilder = toStrict . toLazyByteString
 
+-- | This orphan instance is so we don't have to insert @name@ calls
+-- in dozens and dozens of environment specs.
+instance IsString Name where
+  fromString = name . fromString
+
 -- | Returns an s-expression formatted diff for the specified FilePath pair.
 diffFilePaths :: TaskConfig -> Both FilePath -> IO ByteString
 diffFilePaths (TaskConfig config logger statter) paths = readFilePair paths >>= runTaskWithConfig config logger statter . runDiff SExpressionDiffRenderer . pure >>= either (die . displayException) (pure . runBuilder)

test/fixtures/javascript/analysis/exports/lib.js

@@ -0,0 +1,6 @@
+export function square(x) {
+    return x * x;
+}
+export function area(x, y) {
+  return x * y;
+}

test/fixtures/javascript/analysis/exports/main.js

@@ -0,0 +1,3 @@
+import { square, area } from 'lib';
+console.log(square(11)); // 121
+console.log(area(4, 3)); // 12

vendor/effects

@@ -1 +1 @@
-Subproject commit 105a543ccc98f2929cf0b1f1e97bcc48dfb8f718
+Subproject commit 0b6d04713b70e6b0551b841304fb44c9b1564e9b