diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 1e44c35b0..481f50a1d 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/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 diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index f982eff1f..5d5640845 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/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) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index fbbd7afaf..02a14d3eb 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -30,7 +30,7 @@ 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 = send . PutEnv diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 413340276..78bd3ab25 100644 --- a/src/Data/Abstract/Cache.hs +++ b/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 diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 198580de9..25f3557ab 100644 --- a/src/Data/Abstract/Environment.hs +++ b/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 diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index dc0aa2c5f..b235ed56b 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/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)) @@ -154,24 +154,24 @@ instance HasPrelude 'PHP instance HasPrelude 'Python where definePrelude _ = - define "print" builtInPrint + define (name "print") builtInPrint instance HasPrelude 'Ruby where definePrelude _ = do - define "puts" builtInPrint + define (name "puts") builtInPrint - defineClass "Object" [] $ do - define "inspect" (lambda (const (box (string "")))) + defineClass (name "Object") [] $ do + define (name "inspect") (lambda (const (box (string "")))) instance HasPrelude 'TypeScript where definePrelude _ = - defineNamespace "console" $ do - define "log" builtInPrint + defineNamespace (name "console") $ do + define (name "log") builtInPrint instance HasPrelude 'JavaScript where definePrelude _ = do - defineNamespace "console" $ do - define "log" builtInPrint + defineNamespace (name "console") $ do + define (name "log") builtInPrint -- Postludes diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index 8c68b1dee..ddfee1e89 100644 --- a/src/Data/Abstract/Name.hs +++ b/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" diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index aa4580e0b..3a4561fc4 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/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 diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index abf307cbf..a7b594c38 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/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 diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 34192cb2b..6fa553857 100644 --- a/src/Data/Map/Monoidal.hs +++ b/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 diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 148127c94..94c020d08 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/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) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index f515fe218..3fba9f25f 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/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 diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 892abd6bb..f6b456f78 100644 --- a/src/Semantic/Graph.hs +++ b/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 - let analyzeTerm = withTermSpans . graphingTerms - analyzeModule = (if includePackages then graphingPackages else id) . graphingModules - extractGraph (_, (_, (graph, _))) = simplify graph - runGraphAnalysis - = runState lowerBound - . runFresh 0 - . resumingLoadError - . resumingUnspecialized - . resumingEnvironmentError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . resumingValueError - . runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _ effs)) - . graphing - . runReader (packageInfo package) - . runReader lowerBound - . runReader lowerBound - . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules))) + modules <- topologicalSort <$> runImportGraph lang package + runCallGraph lang includePackages modules package + +runCallGraph :: ( HasField ann Span + , Element Syntax.Identifier syntax + , Base term ~ TermF (Sum syntax) (Record ann) + , Ord term + , Corecursive term + , Declarations term + , Evaluatable (Base term) + , FreeVariables term + , HasPrelude lang + , HasPostlude lang + , Member Trace effs + , Recursive term + , Effects effs + ) + => Proxy lang + -> Bool + -> [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 . 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) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index bb950b660..a524d78fe 100644 --- a/src/Semantic/Util.hs +++ b/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 diff --git a/test/Diffing/Algorithm/RWS/Spec.hs b/test/Diffing/Algorithm/RWS/Spec.hs index 5a74597e9..aaf93710a 100644 --- a/test/Diffing/Algorithm/RWS/Spec.hs +++ b/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 diff --git a/test/Diffing/Interpreter/Spec.hs b/test/Diffing/Interpreter/Spec.hs index 75cb107dc..d1e2d5700 100644 --- a/test/Diffing/Interpreter/Spec.hs +++ b/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 diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index a9e7aa7cf..af8a74039 100644 --- a/test/SpecHelpers.hs +++ b/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) diff --git a/test/fixtures/javascript/analysis/exports/lib.js b/test/fixtures/javascript/analysis/exports/lib.js new file mode 100644 index 000000000..ba64ec931 --- /dev/null +++ b/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; +} diff --git a/test/fixtures/javascript/analysis/exports/main.js b/test/fixtures/javascript/analysis/exports/main.js new file mode 100644 index 000000000..5ce529dbb --- /dev/null +++ b/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