mirror of
https://github.com/github/semantic.git
synced 2024-12-19 12:51:52 +03:00
Make Evaluator use effectful trace rather than Debug.Trace.
This commit is contained in:
Patrick Thomson
parent
3b497bd278
commit
bedba61867
@ -7,6 +7,8 @@ module Control.Abstract.Evaluator
|
||||
, ModuleTable
|
||||
, Exports
|
||||
, JumpTable
|
||||
-- * Trace
|
||||
, traceE
|
||||
-- * Environment
|
||||
, getEnv
|
||||
, putEnv
|
||||
@ -70,6 +72,7 @@ module Control.Abstract.Evaluator
|
||||
, module Control.Monad.Effect.Reader
|
||||
, module Control.Monad.Effect.Resumable
|
||||
, module Control.Monad.Effect.State
|
||||
, Trace (..)
|
||||
, Eff.relay
|
||||
) where
|
||||
|
||||
@ -81,6 +84,7 @@ import Control.Monad.Effect.NonDet
|
||||
import Control.Monad.Effect.Reader hiding (runReader)
|
||||
import Control.Monad.Effect.Resumable
|
||||
import Control.Monad.Effect.State hiding (runState)
|
||||
import Control.Monad.Effect.Trace
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Configuration
|
||||
import Data.Abstract.Environment as Env
|
||||
@ -95,7 +99,7 @@ import qualified Data.IntMap as IntMap
|
||||
import Data.Semigroup.Reducer
|
||||
import Data.Semilattice.Lower
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
import Prologue hiding (trace)
|
||||
|
||||
newtype Evaluator location term value effects a = Evaluator { runEvaluator :: Eff.Eff effects a }
|
||||
deriving (Applicative, Effectful, Functor, Monad)
|
||||
@ -123,6 +127,10 @@ modifyEnv = raise . modify'
|
||||
withEnv :: Member (State (Environment location value)) effects => Environment location value -> Evaluator location term value effects a -> Evaluator location term value effects a
|
||||
withEnv = raiseHandler . localState . const
|
||||
|
||||
-- TODO: move and generalize
|
||||
traceE :: Member Trace effects => String -> Evaluator location term value effects ()
|
||||
traceE = raise . trace
|
||||
|
||||
|
||||
-- | Retrieve the default environment.
|
||||
defaultEnvironment :: Member (Reader (Environment location value)) effects => Evaluator location term value effects (Environment location value)
|
||||
|
||||
@ -81,6 +81,7 @@ type EvaluatableConstraints location term value effects =
|
||||
, State (Exports location value)
|
||||
, State (Heap location value)
|
||||
, State (ModuleTable (Environment location value, value))
|
||||
, Trace
|
||||
] effects
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
@ -253,8 +254,8 @@ resolve names = do
|
||||
tbl <- askModuleTable
|
||||
pure $ find (`ModuleTable.member` tbl) names
|
||||
|
||||
traceResolve :: (Show a, Show b) => a -> b -> c -> c
|
||||
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
|
||||
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location term value effects ()
|
||||
traceResolve name path = traceE ("resolved " <> show name <> " -> " <> show path)
|
||||
|
||||
listModulesInDir :: Member (Reader (ModuleTable [Module term])) effects
|
||||
=> FilePath
|
||||
@ -271,6 +272,7 @@ require :: Members '[ EvalModule term value
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (ModuleTable (Environment location value, value))
|
||||
, Trace
|
||||
] effects
|
||||
=> ModulePath
|
||||
-> Evaluator location term value effects (Maybe (Environment location value, value))
|
||||
@ -286,6 +288,7 @@ load :: Members '[ EvalModule term value
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (ModuleTable (Environment location value, value))
|
||||
, Trace
|
||||
] effects
|
||||
=> ModulePath
|
||||
-> Evaluator location term value effects (Maybe (Environment location value, value))
|
||||
@ -300,7 +303,7 @@ load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= run
|
||||
then trace ("load (skip evaluating, circular load): " <> show mPath) (pure Nothing)
|
||||
else do
|
||||
v <- localLoadStack (loadStackPush (moduleInfo x)) (trace ("load (evaluating): " <> show mPath) (evaluateModule x))
|
||||
traceM ("load done:" <> show mPath)
|
||||
traceE ("load done:" <> show mPath)
|
||||
env <- filterEnv <$> getExports <*> getEnv
|
||||
modifyModuleTable (ModuleTable.insert name (env, v))
|
||||
pure (Just (env, v))
|
||||
@ -331,6 +334,7 @@ evaluatePackageWith :: ( Evaluatable (Base term)
|
||||
, Members '[ Fail
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
, Trace
|
||||
] effects
|
||||
, Recursive term
|
||||
, termEffects ~ (LoopControl value ': Return value ': EvalClosure term value ': moduleEffects)
|
||||
@ -350,6 +354,7 @@ evaluatePackageBodyWith :: ( Evaluatable (Base term)
|
||||
, Members '[ Fail
|
||||
, Reader (Environment location value)
|
||||
, State (Environment location value)
|
||||
, Trace
|
||||
] effects
|
||||
, Recursive term
|
||||
, termEffects ~ (LoopControl value ': Return value ': EvalClosure term value ': moduleEffects)
|
||||
|
||||
@ -32,6 +32,7 @@ resolveGoImport :: Members '[ Reader ModuleInfo
|
||||
, Reader (ModuleTable [Module term])
|
||||
, Reader Package.PackageInfo
|
||||
, Resumable ResolutionError
|
||||
, Trace
|
||||
] effects
|
||||
=> ImportPath
|
||||
-> Evaluator location term value effects [ModulePath]
|
||||
@ -43,9 +44,9 @@ resolveGoImport (ImportPath path Relative) = do
|
||||
_ -> pure paths
|
||||
resolveGoImport (ImportPath path NonRelative) = do
|
||||
package <- BC.unpack . unName . Package.packageName <$> currentPackage
|
||||
traceM ("attempting to resolve " <> show path <> " for package " <> package)
|
||||
traceE ("attempting to resolve " <> show path <> " for package " <> package)
|
||||
case splitDirectories path of
|
||||
-- Import an absolute path that's defined in this package being analyized.
|
||||
-- Import an absolute path that's defined in this package being analyzed.
|
||||
-- First two are source, next is package name, remaining are path to package
|
||||
-- (e.g. github.com/golang/<package>/path...).
|
||||
(_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs)
|
||||
@ -65,7 +66,8 @@ instance Evaluatable Import where
|
||||
eval (Import importPath _) = do
|
||||
paths <- resolveGoImport importPath
|
||||
for_ paths $ \path -> do
|
||||
importedEnv <- maybe emptyEnv fst <$> traceResolve (unPath importPath) path (isolate (require path))
|
||||
traceResolve (unPath importPath) path
|
||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||
modifyEnv (mergeEnvs importedEnv)
|
||||
unit
|
||||
|
||||
@ -86,9 +88,9 @@ instance Evaluatable QualifiedImport where
|
||||
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
|
||||
void $ letrec' alias $ \addr -> do
|
||||
for_ paths $ \path -> do
|
||||
importedEnv <- maybe emptyEnv fst <$> traceResolve (unPath importPath) path (isolate (require path))
|
||||
traceResolve (unPath importPath) path
|
||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||
modifyEnv (mergeEnvs importedEnv)
|
||||
|
||||
makeNamespace alias addr Nothing
|
||||
unit
|
||||
|
||||
@ -103,7 +105,8 @@ instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Evaluatable SideEffectImport where
|
||||
eval (SideEffectImport importPath _) = do
|
||||
paths <- resolveGoImport importPath
|
||||
for_ paths $ \path -> traceResolve (unPath importPath) path $ isolate (require path)
|
||||
traceResolve (unPath importPath) paths
|
||||
for_ paths $ \path -> isolate (require path)
|
||||
unit
|
||||
|
||||
-- A composite literal in Go
|
||||
|
||||
@ -51,6 +51,7 @@ include :: ( AbstractValue location term value effects
|
||||
, Resumable ResolutionError
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, Trace
|
||||
] effects
|
||||
)
|
||||
=> Subterm term (Evaluator location term value effects value)
|
||||
@ -59,7 +60,8 @@ include :: ( AbstractValue location term value effects
|
||||
include pathTerm f = do
|
||||
name <- subtermValue pathTerm >>= asString
|
||||
path <- resolvePHPName name
|
||||
(importedEnv, v) <- traceResolve name path (isolate (f path)) >>= maybeM ((,) emptyEnv <$> unit)
|
||||
traceResolve name path
|
||||
(importedEnv, v) <- (isolate (f path)) >>= maybeM ((,) emptyEnv <$> unit)
|
||||
modifyEnv (mergeEnvs importedEnv)
|
||||
pure v
|
||||
|
||||
|
||||
@ -54,6 +54,7 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (BC.unpack prefix) (J
|
||||
resolvePythonModules :: Members '[ Reader ModuleInfo
|
||||
, Reader (ModuleTable [Module term])
|
||||
, Resumable ResolutionError
|
||||
, Trace
|
||||
] effects
|
||||
=> QualifiedName
|
||||
-> Evaluator location term value effects (NonEmpty ModulePath)
|
||||
@ -61,7 +62,7 @@ resolvePythonModules q = do
|
||||
relRootDir <- rootDir q <$> currentModule
|
||||
for (moduleNames q) $ \name -> do
|
||||
x <- search relRootDir name
|
||||
traceResolve name x $ pure x
|
||||
x <$ traceResolve name x
|
||||
where
|
||||
rootDir (QualifiedName _) ModuleInfo{..} = mempty -- overall rootDir of the Package.
|
||||
rootDir (RelativeQualifiedName n _) ModuleInfo{..} = upDir numDots (takeDirectory modulePath)
|
||||
@ -74,7 +75,7 @@ resolvePythonModules q = do
|
||||
moduleNames (RelativeQualifiedName _ (Just paths)) = moduleNames paths
|
||||
|
||||
search rootDir x = do
|
||||
traceM ("searching for " <> show x <> " in " <> show rootDir)
|
||||
traceE ("searching for " <> show x <> " in " <> show rootDir)
|
||||
let path = normalise (rootDir </> normalise x)
|
||||
let searchPaths = [ path </> "__init__.py"
|
||||
, path <.> ".py"
|
||||
|
||||
@ -68,7 +68,8 @@ instance Evaluatable Require where
|
||||
eval (Require _ x) = do
|
||||
name <- subtermValue x >>= asString
|
||||
path <- resolveRubyName name
|
||||
(importedEnv, v) <- traceResolve name path (isolate (doRequire path))
|
||||
traceResolve name path
|
||||
(importedEnv, v) <- isolate (doRequire path)
|
||||
modifyEnv (`mergeNewer` importedEnv)
|
||||
pure v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
|
||||
|
||||
@ -81,6 +82,7 @@ doRequire :: ( AbstractValue location term value effects
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (ModuleTable (Environment location value, value))
|
||||
, Trace
|
||||
] effects
|
||||
)
|
||||
=> M.ModulePath
|
||||
@ -118,6 +120,7 @@ doLoad :: ( AbstractValue location term value effects
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (ModuleTable (Environment location value, value))
|
||||
, Trace
|
||||
] effects
|
||||
)
|
||||
=> ByteString
|
||||
@ -125,7 +128,8 @@ doLoad :: ( AbstractValue location term value effects
|
||||
-> Evaluator location term value effects value
|
||||
doLoad path shouldWrap = do
|
||||
path' <- resolveRubyPath path
|
||||
importedEnv <- maybe emptyEnv fst <$> traceResolve path path' (isolate (load path'))
|
||||
traceResolve path path'
|
||||
importedEnv <- maybe emptyEnv fst <$> (isolate (load path'))
|
||||
unless shouldWrap $ modifyEnv (mergeEnvs importedEnv)
|
||||
boolean Prelude.True -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load
|
||||
|
||||
|
||||
@ -37,6 +37,7 @@ toName = FV.name . BC.pack . unPath
|
||||
resolveWithNodejsStrategy :: Members '[ Reader M.ModuleInfo
|
||||
, Reader (ModuleTable [M.Module term])
|
||||
, Resumable ResolutionError
|
||||
, Trace
|
||||
] effects
|
||||
=> ImportPath
|
||||
-> [String]
|
||||
@ -54,6 +55,7 @@ resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativ
|
||||
resolveRelativePath :: Members '[ Reader M.ModuleInfo
|
||||
, Reader (ModuleTable [M.Module term])
|
||||
, Resumable ResolutionError
|
||||
, Trace
|
||||
] effects
|
||||
=> FilePath
|
||||
-> [String]
|
||||
@ -62,7 +64,7 @@ resolveRelativePath relImportPath exts = do
|
||||
M.ModuleInfo{..} <- currentModule
|
||||
let relRootDir = takeDirectory modulePath
|
||||
let path = joinPaths relRootDir relImportPath
|
||||
resolveTSModule path exts >>= either notFound (\x -> traceResolve relImportPath x (pure x))
|
||||
resolveTSModule path exts >>= either notFound (\x -> x <$ traceResolve relImportPath path)
|
||||
where
|
||||
notFound xs = throwResumable $ NotFoundError relImportPath xs Language.TypeScript
|
||||
|
||||
@ -79,6 +81,7 @@ resolveRelativePath relImportPath exts = do
|
||||
resolveNonRelativePath :: Members '[ Reader M.ModuleInfo
|
||||
, Reader (ModuleTable [M.Module term])
|
||||
, Resumable ResolutionError
|
||||
, Trace
|
||||
] effects
|
||||
=> FilePath
|
||||
-> [String]
|
||||
@ -94,7 +97,7 @@ resolveNonRelativePath name exts = do
|
||||
case res of
|
||||
Left xs | parentDir <- takeDirectory path , root /= parentDir -> go root parentDir (searched <> xs)
|
||||
| otherwise -> notFound (searched <> xs)
|
||||
Right m -> traceResolve name m $ pure m
|
||||
Right m -> m <$ traceResolve name m
|
||||
notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript
|
||||
|
||||
resolveTSModule :: Members '[ Reader (ModuleTable [M.Module term]) ] effects
|
||||
@ -126,6 +129,7 @@ evalRequire :: ( AbstractValue location term value effects
|
||||
, State (Exports location value)
|
||||
, State (Heap location value)
|
||||
, State (ModuleTable (Environment location value, value))
|
||||
, Trace
|
||||
] effects
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
|
||||
@ -4,6 +4,7 @@ module Semantic.Graph where
|
||||
import Analysis.Abstract.Evaluating
|
||||
import Analysis.Abstract.Graph
|
||||
import qualified Control.Exception as Exc
|
||||
import Control.Monad.Effect (relayState, send)
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Located
|
||||
@ -43,6 +44,7 @@ graph graphType renderer project
|
||||
runGraphAnalysis
|
||||
= run
|
||||
. evaluating
|
||||
. ignoringTraces
|
||||
. resumingLoadError
|
||||
. resumingUnspecialized
|
||||
. resumingValueError
|
||||
@ -55,6 +57,15 @@ graph graphType renderer project
|
||||
constrainingTypes :: Evaluator (Located Precise) term (Value (Located Precise)) effects a -> Evaluator (Located Precise) term (Value (Located Precise)) effects a
|
||||
constrainingTypes = id
|
||||
|
||||
ignoringTraces :: Effectful m => m (Trace ': effects) a -> m effects a
|
||||
ignoringTraces = runEffect (\(Trace _) yield -> yield ())
|
||||
|
||||
printingTraces :: (Member IO effects, Effectful m) => m (Trace ': effects) a -> m effects a
|
||||
printingTraces = raiseHandler (relay pure (\(Trace s) yield -> send (putStrLn s) >>= yield))
|
||||
|
||||
returningTraces :: (Functor (m effects), Effectful m) => m (Trace ': effects) a -> m effects (a, [String])
|
||||
returningTraces e = fmap reverse <$> raiseHandler (relayState [] (\ts a -> pure (a, ts)) (\ts (Trace s) yield -> yield (s : ts) ())) e
|
||||
|
||||
-- | Parse a list of files into a 'Package'.
|
||||
parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
|
||||
=> Parser term -- ^ A parser.
|
||||
|
||||
@ -6,6 +6,7 @@ import Analysis.Abstract.Caching
|
||||
import Analysis.Abstract.Collecting
|
||||
import Analysis.Abstract.Evaluating as X
|
||||
import Control.Abstract.Evaluator
|
||||
import Control.Monad.Effect (runM)
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Value
|
||||
@ -25,8 +26,9 @@ import qualified Language.Python.Assignment as Python
|
||||
import qualified Language.Ruby.Assignment as Ruby
|
||||
|
||||
justEvaluating
|
||||
= run
|
||||
= runM . lower
|
||||
. evaluating
|
||||
. printingTraces
|
||||
. runLoadError
|
||||
. runValueError
|
||||
. runUnspecialized
|
||||
@ -35,8 +37,9 @@ justEvaluating
|
||||
. runAddressError
|
||||
|
||||
evaluatingWithHoles
|
||||
= run
|
||||
= runM . lower
|
||||
. evaluating
|
||||
. printingTraces
|
||||
. resumingLoadError
|
||||
. resumingUnspecialized
|
||||
. resumingValueError
|
||||
@ -46,8 +49,9 @@ evaluatingWithHoles
|
||||
|
||||
-- The order is significant here: caching has to run before typeChecking, or else we’ll nondeterministically produce TypeErrors as part of the result set. While this is probably actually correct, it will require us to have an Ord instance for TypeError, which we don’t have yet.
|
||||
checking
|
||||
= run
|
||||
= runM . lower
|
||||
. evaluating
|
||||
. printingTraces
|
||||
. providingLiveSet
|
||||
. runLoadError
|
||||
. runUnspecialized
|
||||
@ -57,14 +61,14 @@ checking
|
||||
. runTypeError
|
||||
. caching @[]
|
||||
|
||||
evalGoProject path = justEvaluating <$> evaluateProject goParser Language.Go Nothing path
|
||||
evalRubyProject path = justEvaluating <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
|
||||
evalPHPProject path = justEvaluating <$> evaluateProject phpParser Language.PHP Nothing path
|
||||
evalPythonProject path = justEvaluating <$> evaluateProject pythonParser Language.Python pythonPrelude path
|
||||
evalTypeScriptProjectQuietly path = evaluatingWithHoles <$> evaluateProject typescriptParser Language.TypeScript Nothing path
|
||||
evalTypeScriptProject path = justEvaluating <$> evaluateProject typescriptParser Language.TypeScript Nothing path
|
||||
evalGoProject path = justEvaluating =<< evaluateProject goParser Language.Go Nothing path
|
||||
evalRubyProject path = justEvaluating =<< evaluateProject rubyParser Language.Ruby rubyPrelude path
|
||||
evalPHPProject path = justEvaluating =<< evaluateProject phpParser Language.PHP Nothing path
|
||||
evalPythonProject path = justEvaluating =<< evaluateProject pythonParser Language.Python pythonPrelude path
|
||||
evalTypeScriptProjectQuietly path = evaluatingWithHoles =<< evaluateProject typescriptParser Language.TypeScript Nothing path
|
||||
evalTypeScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.TypeScript Nothing path
|
||||
|
||||
typecheckGoFile path = checking <$> evaluateProjectWithCaching goParser Language.Go Nothing path
|
||||
typecheckGoFile path = checking =<< evaluateProjectWithCaching goParser Language.Go Nothing path
|
||||
|
||||
rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby)
|
||||
pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user