diff --git a/semantic.cabal b/semantic.cabal index 6d22c85b5..bf92811c4 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -22,7 +22,6 @@ library Analysis.Abstract.Caching , Analysis.Abstract.Collecting , Analysis.Abstract.Dead - , Analysis.Abstract.Evaluating , Analysis.Abstract.Graph , Analysis.Abstract.Tracing , Analysis.ConstructorName diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs deleted file mode 100644 index 6da064c3b..000000000 --- a/src/Analysis/Abstract/Evaluating.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Analysis.Abstract.Evaluating -( EvaluatingState(..) -, evaluating -) where - -import Control.Abstract -import Prologue - --- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -data EvaluatingState address value = EvaluatingState - { heap :: Heap address (Cell address) value - , modules :: ModuleTable (Maybe (address, Environment address)) - } - -deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value) -deriving instance (Ord (Cell address value), Ord address, Ord value) => Ord (EvaluatingState address value) -deriving instance (Show (Cell address value), Show address, Show value) => Show (EvaluatingState address value) - - -evaluating :: Evaluator address value - ( Fresh - ': State (Heap address (Cell address) value) - ': State (ModuleTable (Maybe (address, Environment address))) - ': effects) result - -> Evaluator address value effects (result, EvaluatingState address value) -evaluating - = fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules)) - . runState lowerBound -- State (ModuleTable (Maybe (address, Environment address))) - . runState lowerBound -- State (Heap address (Cell address) value) - . runFresh 0 diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index ad44d3654..5a7431529 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -2,6 +2,7 @@ module Analysis.Abstract.Graph ( Graph(..) , Vertex(..) +, moduleVertex , style , appendGraph , variableDefinition @@ -10,6 +11,7 @@ module Analysis.Abstract.Graph , graphingTerms , graphingPackages , graphingModules +, graphingModuleInfo , graphing ) where @@ -59,6 +61,7 @@ graphingTerms recur term@(In _ syntax) = do _ -> pure () recur term +-- | Add vertices to the graph for evaluated modules and the packages containing them. graphingPackages :: ( Member (Reader PackageInfo) effects , Member (State (Graph Vertex)) effects ) @@ -66,19 +69,37 @@ graphingPackages :: ( Member (Reader PackageInfo) effects -> SubtermAlgebra Module term (TermEvaluator term address value effects a) graphingPackages recur m = packageInclusion (moduleVertex (moduleInfo m)) *> recur m --- | Add vertices to the graph for evaluated modules and the packages containing them. +-- | Add vertices to the graph for imported modules. graphingModules :: forall term address value effects a - . ( Member (Modules address value) effects + . ( Member (Modules address) effects , Member (Reader ModuleInfo) effects , Member (State (Graph Vertex)) effects ) - => SubtermAlgebra Module term (TermEvaluator term address value effects a) - -> SubtermAlgebra Module term (TermEvaluator term address value effects a) -graphingModules recur m = interpose @(Modules address value) pure (\ m yield -> case m of - Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield - Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield - _ -> send m >>= yield) - (recur m) + => SubtermAlgebra Module term (TermEvaluator term address value effects a) + -> SubtermAlgebra Module term (TermEvaluator term address value effects a) +graphingModules recur m = do + appendGraph (vertex (moduleVertex (moduleInfo m))) + interpose @(Modules address) pure (\ m yield -> case m of + Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield + Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield + _ -> send m >>= yield) + (recur m) + +-- | Add vertices to the graph for imported modules. +graphingModuleInfo :: forall term address value effects a + . ( Member (Modules address) effects + , Member (Reader ModuleInfo) effects + , Member (State (Graph ModuleInfo)) effects + ) + => SubtermAlgebra Module term (TermEvaluator term address value effects a) + -> SubtermAlgebra Module term (TermEvaluator term address value effects a) +graphingModuleInfo recur m = do + appendGraph (vertex (moduleInfo m)) + interpose @(Modules address) pure (\ eff yield -> case eff of + Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex >> send eff >>= yield + Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex >> send eff >>= yield + _ -> send eff >>= yield) + (recur m) -- | Add an edge from the current package to the passed vertex. packageInclusion :: ( Effectful m @@ -114,7 +135,7 @@ variableDefinition name = do graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe) <$> TermEvaluator (lookupEnv name) appendGraph (vertex (Variable (formatName name)) `connect` graph) -appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects () +appendGraph :: (Effectful m, Member (State (Graph v)) effects) => Graph v -> m effects () appendGraph = modify' . (<>) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 4123c7475..e60094c65 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Modules ( lookupModule , resolve @@ -23,115 +23,88 @@ import Data.Abstract.Environment import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Language +import Data.Semigroup.Foldable (foldMap1) +import qualified Data.Set as Set import Prologue +import System.FilePath.Posix (takeDirectory) --- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load. -lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (address, Environment address))) +-- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load. +lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address)) lookupModule = sendModules . Lookup -- | Resolve a list of module paths to a possible module table entry. -resolve :: forall address value effects . Member (Modules address value) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath) -resolve = sendModules . Resolve @address @value +resolve :: Member (Modules address) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath) +resolve = sendModules . Resolve -listModulesInDir :: forall address value effects . Member (Modules address value) effects => FilePath -> Evaluator address value effects [ModulePath] -listModulesInDir = sendModules . List @address @value +listModulesInDir :: Member (Modules address) effects => FilePath -> Evaluator address value effects [ModulePath] +listModulesInDir = sendModules . List -- | Require/import another module by name and return its environment and value. -- -- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. -require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address)) +require :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (address, Environment address) require path = lookupModule path >>= maybeM (load path) -- | Load another module by name and return its environment and value. -- -- Always loads/evaluates. -load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address)) +load :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (address, Environment address) load path = sendModules (Load path) -data Modules address value return where - Load :: ModulePath -> Modules address value (Maybe (address, Environment address)) - Lookup :: ModulePath -> Modules address value (Maybe (Maybe (address, Environment address))) - Resolve :: [FilePath] -> Modules address value (Maybe ModulePath) - List :: FilePath -> Modules address value [ModulePath] +data Modules address return where + Load :: ModulePath -> Modules address (address, Environment address) + Lookup :: ModulePath -> Modules address (Maybe (address, Environment address)) + Resolve :: [FilePath] -> Modules address (Maybe ModulePath) + List :: FilePath -> Modules address [ModulePath] -sendModules :: Member (Modules address value) effects => Modules address value return -> Evaluator address value effects return +sendModules :: Member (Modules address) effects => Modules address return -> Evaluator address value effects return sendModules = send -runModules :: forall term address value effects a - . ( Member (Resumable (LoadError address value)) effects - , Member (State (ModuleTable (Maybe (address, Environment address)))) effects - , Member Trace effects +runModules :: ( Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47 + , Member (Resumable (LoadError address)) effects ) - => (Module term -> Evaluator address value (Modules address value ': effects) (address, Environment address)) - -> Evaluator address value (Modules address value ': effects) a - -> Evaluator address value (Reader (ModuleTable (NonEmpty (Module term))) ': effects) a -runModules evaluateModule = go - where go :: forall a . Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Reader (ModuleTable (NonEmpty (Module term))) ': effects) a - go = reinterpret (\ m -> case m of - Load name -> askModuleTable @term >>= maybe (moduleNotFound name) (runMerging . foldMap (Merging . evalAndCache)) . ModuleTable.lookup name - where - evalAndCache x = do - let mPath = modulePath (moduleInfo x) - loading <- loadingModule mPath - if loading - then trace ("load (skip evaluating, circular load): " <> show mPath) $> Nothing - else do - _ <- cacheModule name Nothing - result <- trace ("load (evaluating): " <> show mPath) *> go (evaluateModule x) <* trace ("load done:" <> show mPath) - cacheModule name (Just result) + => Set ModulePath + -> Evaluator address value (Modules address ': effects) a + -> Evaluator address value effects a +runModules paths = interpret $ \case + Load name -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (moduleNotFound name) + Lookup path -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path <$> askModuleTable + Resolve names -> pure (find (`Set.member` paths) names) + List dir -> pure (filter ((dir ==) . takeDirectory) (toList paths)) - loadingModule path = isJust . ModuleTable.lookup path <$> getModuleTable - Lookup path -> ModuleTable.lookup path <$> get - Resolve names -> do - isMember <- flip ModuleTable.member <$> askModuleTable @term - pure (find isMember names) - List dir -> modulePathsInDir dir <$> askModuleTable @term) - -getModuleTable :: Member (State (ModuleTable (Maybe (address, Environment address)))) effects => Evaluator address value effects (ModuleTable (Maybe (address, Environment address))) -getModuleTable = get - -cacheModule :: Member (State (ModuleTable (Maybe (address, Environment address)))) effects => ModulePath -> Maybe (address, Environment address) -> Evaluator address value effects (Maybe (address, Environment address)) -cacheModule path result = modify' (ModuleTable.insert path result) $> result - -askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module term)))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module term))) -askModuleTable = ask +askModuleTable :: Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module (address, Environment address)))) +askModuleTable = get -newtype Merging m address value = Merging { runMerging :: m (Maybe (address, Environment address)) } +newtype Merging address = Merging { runMerging :: (address, Environment address) } -instance Applicative m => Semigroup (Merging m address value) where - Merging a <> Merging b = Merging (merge <$> a <*> b) - where merge a b = mergeJusts <$> a <*> b <|> a <|> b - mergeJusts (_, env1) (v, env2) = (v, mergeEnvs env1 env2) - -instance Applicative m => Monoid (Merging m address value) where - mappend = (<>) - mempty = Merging (pure Nothing) +instance Semigroup (Merging address) where + Merging (_, env1) <> Merging (addr, env2) = Merging (addr, mergeEnvs env1 env2) -- | 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 address value resume where - ModuleNotFound :: ModulePath -> LoadError address value (Maybe (address, Environment address)) +data LoadError address resume where + ModuleNotFound :: ModulePath -> LoadError address (address, Environment address) -deriving instance Eq (LoadError address value resume) -deriving instance Show (LoadError address value resume) -instance Show1 (LoadError address value) where +deriving instance Eq (LoadError address resume) +deriving instance Show (LoadError address resume) +instance Show1 (LoadError address) where liftShowsPrec _ _ = showsPrec -instance Eq1 (LoadError address value) where +instance Eq1 (LoadError address) where liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b -moduleNotFound :: forall address value effects . Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address)) -moduleNotFound = throwResumable . ModuleNotFound @address @value +moduleNotFound :: Member (Resumable (LoadError address)) effects => ModulePath -> Evaluator address value effects (address, Environment address) +moduleNotFound = throwResumable . ModuleNotFound -resumeLoadError :: Member (Resumable (LoadError address value)) effects => Evaluator address value effects a -> (forall resume . LoadError address value resume -> Evaluator address value effects resume) -> Evaluator address value effects a +resumeLoadError :: Member (Resumable (LoadError address)) effects => Evaluator address value effects a -> (forall resume . LoadError address resume -> Evaluator address value effects resume) -> Evaluator address value effects a resumeLoadError = catchResumable -runLoadError :: Effectful (m address value) => m address value (Resumable (LoadError address value) ': effects) a -> m address value effects (Either (SomeExc (LoadError address value)) a) +runLoadError :: Effectful (m address value) => m address value (Resumable (LoadError address) ': effects) a -> m address value effects (Either (SomeExc (LoadError address)) a) runLoadError = runResumable -runLoadErrorWith :: Effectful (m address value) => (forall resume . LoadError address value resume -> m address value effects resume) -> m address value (Resumable (LoadError address value) ': effects) a -> m address value effects a +runLoadErrorWith :: Effectful (m address value) => (forall resume . LoadError address resume -> m address value effects resume) -> m address value (Resumable (LoadError address) ': effects) a -> m address value effects a runLoadErrorWith = runResumableWith diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 530b8da95..a1d836995 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE GADTs, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-} module Data.Abstract.Evaluatable ( module X , Evaluatable(..) -, evaluatePackageWith +, evaluate , traceResolve -- * Preludes , HasPrelude(..) @@ -17,7 +17,7 @@ module Data.Abstract.Evaluatable , Cell ) where -import Control.Abstract +import Control.Abstract hiding (Load) import Control.Abstract.Context as X import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith) import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) @@ -30,8 +30,8 @@ import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Name as X -import Data.Abstract.Package as Package import Data.Abstract.Ref as X +import Data.Coerce import Data.Language import Data.Scientific (Scientific) import Data.Semigroup.App @@ -49,7 +49,7 @@ class Show1 constr => Evaluatable constr where , Member (Allocator address value) effects , Member (Env address) effects , Member (LoopControl address) effects - , Member (Modules address value) effects + , Member (Modules address) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Reader Span) effects @@ -64,77 +64,58 @@ class Show1 constr => Evaluatable constr where eval expr = rvalBox =<< throwResumable (Unspecialized ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")) --- | Evaluate a given package. -evaluatePackageWith :: forall proxy lang address term value inner inner' inner'' outer - . ( AbstractValue address value inner - -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? - , Addressable address inner' - , Declarations term - , Evaluatable (Base term) - , Foldable (Cell address) - , FreeVariables term - , HasPrelude lang - , Member Fresh outer - , Member (Resumable (AddressError address value)) outer - , Member (Resumable (EnvironmentError address)) outer - , Member (Resumable EvalError) outer - , Member (Resumable (LoadError address value)) outer - , Member (Resumable ResolutionError) outer - , Member (Resumable (Unspecialized value)) outer - , Member (State (Heap address (Cell address) value)) outer - , Member (State (ModuleTable (Maybe (address, Environment address)))) outer - , Member Trace outer - , Recursive term - , Reducer value (Cell address value) - , ValueRoots address value - , inner ~ (LoopControl address ': Return address ': Env address ': Allocator address value ': inner') - , inner' ~ (Reader ModuleInfo ': inner'') - , inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer) - ) - => proxy lang - -> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address)) - -> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address))) - -> Package term - -> TermEvaluator term address value outer [(address, Environment address)] -evaluatePackageWith lang analyzeModule analyzeTerm package - = runReader (packageInfo package) - . runReader lowerBound - . runReader (packageModules (packageBody package)) - . withPrelude package - $ \ preludeEnv - -> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv)) - . traverse (uncurry (evaluateEntryPoint preludeEnv)) - $ ModuleTable.toPairs (packageEntryPoints (packageBody package)) - where - evalModule preludeEnv m - = runInModule preludeEnv (moduleInfo m) - . analyzeModule (subtermRef . moduleBody) - $ evalTerm <$> m - evalTerm term = Subterm term (TermEvaluator (address =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term))) +evaluate :: ( AbstractValue address value inner + , Addressable address (Reader ModuleInfo ': effects) + , Declarations term + , Evaluatable (Base term) + , Foldable (Cell address) + , FreeVariables term + , HasPrelude lang + , Member Fresh effects + , Member (Modules address) effects + , Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects + , Member (Reader PackageInfo) effects + , Member (Reader Span) effects + , Member (Resumable (AddressError address value)) effects + , Member (Resumable (EnvironmentError address)) effects + , Member (Resumable EvalError) effects + , Member (Resumable ResolutionError) effects + , Member (Resumable (Unspecialized value)) effects + , Member (State (Heap address (Cell address) value)) effects + , Member Trace effects + , Recursive term + , Reducer value (Cell address value) + , ValueRoots address value + , inner ~ (LoopControl address ': Return address ': Env address ': Allocator address value ': Reader ModuleInfo ': effects) + ) + => proxy lang + -> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address)) + -> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address))) + -> [Module term] + -> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (address, Environment address)))) +evaluate lang analyzeModule analyzeTerm modules = do + (_, preludeEnv) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack $ do + defineBuiltins + definePrelude lang + box unit + foldr (run preludeEnv) get modules + where run preludeEnv m rest = do + evaluated <- coerce + (runInModule preludeEnv (moduleInfo m)) + (analyzeModule (subtermRef . moduleBody) + (evalTerm <$> m)) + -- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module. + modify' (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) + rest + + evalTerm term = Subterm term (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term >>= TermEvaluator . address) runInModule preludeEnv info = runReader info - . raiseHandler runAllocator - . raiseHandler (runEnv preludeEnv) - . raiseHandler runReturn - . raiseHandler runLoopControl - - evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (address, Environment address) - evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do - addr <- box unit -- TODO don't *always* allocate - use maybeM instead - (ptr, env) <- fromMaybe (addr, lowerBound) <$> require m - bindAll env - maybe (pure ptr) ((`call` []) <=< deref <=< variable) sym - - withPrelude :: Package term - -> (Environment address -> TermEvaluator term address value (Reader (ModuleTable (NonEmpty (Module term))) ': Reader Span ': Reader PackageInfo ': outer) a) - -> TermEvaluator term address value (Reader (ModuleTable (NonEmpty (Module term))) ': Reader Span ': Reader PackageInfo ': outer) a - withPrelude _ f = do - (_, preludeEnv) <- raiseHandler (runModules (runTermEvaluator . evalModule lowerBound)) . runInModule lowerBound moduleInfoFromCallStack . TermEvaluator $ do - defineBuiltins - definePrelude lang - box unit - f preludeEnv + . runAllocator + . runEnv preludeEnv + . runReturn + . runLoopControl traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs index ed1880605..5d495ecbf 100644 --- a/src/Data/Abstract/Module.hs +++ b/src/Data/Abstract/Module.hs @@ -12,11 +12,11 @@ import GHC.Stack import Prologue import System.FilePath.Posix -data Module term = Module { moduleInfo :: ModuleInfo, moduleBody :: term } +data Module body = Module { moduleInfo :: ModuleInfo, moduleBody :: body } deriving (Eq, Foldable, Functor, Ord, Traversable) -instance Show (Module term) where - showsPrec _ Module{..} = shows moduleInfo +instance Show body => Show (Module body) where + showsPrec d Module{..} = showsBinaryWith showsPrec showsPrec "Module" d (modulePath moduleInfo) moduleBody -- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'. @@ -32,7 +32,10 @@ moduleForBlob rootDir Blob{..} = Module info type ModulePath = FilePath newtype ModuleInfo = ModuleInfo { modulePath :: ModulePath } - deriving (Eq, Ord, Show) + deriving (Eq, Ord) + +instance Show ModuleInfo where + showsPrec d = showsUnaryWith showsPrec "ModuleInfo" d . modulePath moduleInfoFromSrcLoc :: SrcLoc -> ModuleInfo moduleInfoFromSrcLoc = ModuleInfo . srcLocModule diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs index 1522ad635..57a2670a5 100644 --- a/src/Data/Abstract/ModuleTable.hs +++ b/src/Data/Abstract/ModuleTable.hs @@ -5,6 +5,7 @@ module Data.Abstract.ModuleTable , singleton , lookup , member +, modulePaths , modulePathsInDir , insert , keys @@ -26,6 +27,9 @@ newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a } singleton :: ModulePath -> a -> ModuleTable a singleton name = ModuleTable . Map.singleton name +modulePaths :: ModuleTable a -> Set ModulePath +modulePaths = Map.keysSet . unModuleTable + modulePathsInDir :: FilePath -> ModuleTable a -> [ModulePath] modulePathsInDir k = filter (\e -> k == takeDirectory e) . Map.keys . unModuleTable diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index e604698e2..38136f0c9 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TupleSections #-} module Data.Abstract.Package where import Data.Abstract.Module @@ -12,30 +11,16 @@ type PackageName = Name -- | Metadata for a package (name and version). data PackageInfo = PackageInfo { packageName :: PackageName - , packageVersion :: Maybe Version , packageResolutions :: Map.Map FilePath FilePath } deriving (Eq, Ord, Show) -newtype Version = Version { versionString :: String } - deriving (Eq, Ord, Show) - -data PackageBody term = PackageBody - { packageModules :: ModuleTable (NonEmpty (Module term)) - , packageEntryPoints :: ModuleTable (Maybe Name) - } - deriving (Eq, Functor, Ord, Show) - - -- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed. data Package term = Package { packageInfo :: PackageInfo - , packageBody :: PackageBody term + , packageModules :: ModuleTable (NonEmpty (Module term)) } deriving (Eq, Functor, Ord, Show) -fromModules :: PackageName -> Maybe Version -> Int -> [Module term] -> Map.Map FilePath FilePath -> Package term -fromModules name version entryPoints modules resolutions = - Package (PackageInfo name version resolutions) (PackageBody (ModuleTable.fromModules modules) entryPoints') - where - entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules +fromModules :: PackageName -> [Module term] -> Map.Map FilePath FilePath -> Package term +fromModules name modules resolutions = Package (PackageInfo name resolutions) (ModuleTable.fromModules modules) diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs index f8e6e263d..499ece76d 100644 --- a/src/Data/Graph.hs +++ b/src/Data/Graph.hs @@ -1,32 +1,93 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Data.Graph ( Graph(..) -, Class.overlay -, Class.connect -, Class.vertex +, overlay +, connect +, vertex , Lower(..) , simplify +, topologicalSort ) where import qualified Algebra.Graph as G +import qualified Algebra.Graph.AdjacencyMap as A +import Algebra.Graph.Class (connect, overlay, vertex) import qualified Algebra.Graph.Class as Class +import Control.Monad.Effect +import Control.Monad.Effect.State import Data.Aeson +import qualified Data.Set as Set import Prologue -- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances. -newtype Graph vertex = Graph (G.Graph vertex) - deriving (Eq, Foldable, Functor, Class.Graph, Show, Class.ToGraph, Traversable) +newtype Graph vertex = Graph { unGraph :: G.Graph vertex } + deriving (Alternative, Applicative, Eq, Foldable, Functor, Class.Graph, Monad, Show, Class.ToGraph, Traversable) simplify :: Ord vertex => Graph vertex -> Graph vertex simplify (Graph graph) = Graph (G.simplify graph) +-- | Sort a graph’s vertices topologically. +-- +-- >>> topologicalSort (Class.path "ab") +-- "ba" +-- +-- >>> topologicalSort (Class.path "abc") +-- "cba" +-- +-- >>> topologicalSort ((vertex 'a' `connect` vertex 'b') `connect` vertex 'c') +-- "cba" +-- +-- >>> topologicalSort (vertex 'a' `connect` (vertex 'b' `connect` vertex 'c')) +-- "cba" +-- +-- >>> topologicalSort ((vertex 'a' `connect` vertex 'b') <> (vertex 'a' `connect` vertex 'c')) +-- "cba" +-- +-- >>> topologicalSort (Class.path "abd" <> Class.path "acd") +-- "dcba" +-- +-- >>> topologicalSort (Class.path "aba") +-- "ab" +topologicalSort :: forall v . Ord v => Graph v -> [v] +topologicalSort = go . toAdjacencyMap . G.transpose . unGraph + where go :: A.AdjacencyMap v -> [v] + go graph + = visitedOrder . snd + . run + . runState (Visited lowerBound []) + . traverse_ visit + . A.vertexList + $ graph + where visit :: v -> Eff '[State (Visited v)] () + visit v = do + isMarked <- Set.member v . visitedVertices <$> get + if isMarked then + pure () + else do + modify' (extendVisited (Set.insert v)) + traverse_ visit (Set.toList (A.postSet v graph)) + modify' (extendOrder (v :)) + +data Visited v = Visited { visitedVertices :: !(Set v), visitedOrder :: [v] } + +extendVisited :: (Set v -> Set v) -> Visited v -> Visited v +extendVisited f (Visited a b) = Visited (f a) b + +extendOrder :: ([v] -> [v]) -> Visited v -> Visited v +extendOrder f (Visited a b) = Visited a (f b) + + +toAdjacencyMap :: Ord v => G.Graph v -> A.AdjacencyMap v +toAdjacencyMap = Class.toGraph + + instance Lower (Graph vertex) where lowerBound = Class.empty instance Semigroup (Graph vertex) where - (<>) = Class.overlay + (<>) = overlay instance Monoid (Graph vertex) where mempty = Class.empty diff --git a/src/Data/Project.hs b/src/Data/Project.hs index 19c24a9c3..668fadc4b 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -38,7 +38,6 @@ data ProjectF (blobs :: * -> *) (paths :: * -> *) path = Project { projectRootDir :: path , projectBlobs :: blobs Blob , projectLanguage :: Language - , projectEntryPaths :: paths path , projectExcludeDirs :: paths path } deriving (Functor, Generic) @@ -63,7 +62,6 @@ fromPB Project {..} = Project { projectRootDir = T.unpack projectRootDir , projectBlobs = toList projectBlobs , projectLanguage = projectLanguage - , projectEntryPaths = T.unpack <$> toList projectEntryPaths , projectExcludeDirs = T.unpack <$> toList projectExcludeDirs } diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index b7ad86982..1f7cb5dac 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -27,7 +27,7 @@ importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathT defaultAlias :: ImportPath -> Name defaultAlias = name . T.pack . takeFileName . unPath -resolveGoImport :: ( Member (Modules address value) effects +resolveGoImport :: ( Member (Modules address) effects , Member (Reader ModuleInfo) effects , Member (Reader Package.PackageInfo) effects , Member (Resumable ResolutionError) effects @@ -66,7 +66,7 @@ instance Evaluatable Import where paths <- resolveGoImport importPath for_ paths $ \path -> do traceResolve (unPath importPath) path - importedEnv <- maybe lowerBound snd <$> require path + importedEnv <- snd <$> require path bindAll importedEnv rvalBox unit @@ -88,7 +88,7 @@ instance Evaluatable QualifiedImport where void . letrec' alias $ \addr -> do for_ paths $ \p -> do traceResolve (unPath importPath) p - importedEnv <- maybe lowerBound snd <$> require p + importedEnv <- snd <$> require p bindAll importedEnv makeNamespace alias addr Nothing rvalBox unit diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 254e91223..6d65ec2c0 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -35,7 +35,7 @@ instance Evaluatable VariableName -- file, the complete contents of the included file are treated as though it -- were defined inside that function. -resolvePHPName :: ( Member (Modules address value) effects +resolvePHPName :: ( Member (Modules address) effects , Member (Resumable ResolutionError) effects ) => T.Text @@ -49,20 +49,19 @@ resolvePHPName n = do include :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects - , Member (Modules address value) effects + , Member (Modules address) effects , Member (Resumable ResolutionError) effects , Member (Resumable (EnvironmentError address)) effects , Member Trace effects ) => Subterm term (Evaluator address value effects (ValueRef address)) - -> (ModulePath -> Evaluator address value effects (Maybe (address, Environment address))) + -> (ModulePath -> Evaluator address value effects (address, Environment address)) -> Evaluator address value effects (ValueRef address) include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name traceResolve name path - unitPtr <- box unit -- TODO don't always allocate, use maybeM - (v, importedEnv) <- fromMaybe (unitPtr, lowerBound) <$> f path + (v, importedEnv) <- f path bindAll importedEnv pure (Rval v) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index b968fb218..c79eb1dcb 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -50,7 +50,7 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (T.unpack prefix) (Ju -- Subsequent imports of `parent.two` or `parent.three` will execute -- `parent/two/__init__.py` and -- `parent/three/__init__.py` respectively. -resolvePythonModules :: ( Member (Modules address value) effects +resolvePythonModules :: ( Member (Modules address) effects , Member (Reader ModuleInfo) effects , Member (Resumable ResolutionError) effects , Member Trace effects @@ -113,7 +113,7 @@ instance Evaluatable Import where -- Last module path is the one we want to import let path = NonEmpty.last modulePaths - importedEnv <- maybe lowerBound snd <$> require path + importedEnv <- snd <$> require path bindAll (select importedEnv) rvalBox unit where @@ -126,11 +126,11 @@ instance Evaluatable Import where evalQualifiedImport :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects - , Member (Modules address value) effects + , Member (Modules address) effects ) => Name -> ModulePath -> Evaluator address value effects value evalQualifiedImport name path = letrec' name $ \addr -> do - importedEnv <- maybe lowerBound snd <$> require path + importedEnv <- snd <$> require path bindAll importedEnv unit <$ makeNamespace name addr Nothing @@ -174,7 +174,7 @@ instance Evaluatable QualifiedAliasedImport where alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) rvalBox =<< letrec' alias (\addr -> do let path = NonEmpty.last modulePaths - importedEnv <- maybe lowerBound snd <$> require path + importedEnv <- snd <$> require path bindAll importedEnv unit <$ makeNamespace alias addr Nothing) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 821eb026f..ab894e430 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -16,7 +16,7 @@ import System.FilePath.Posix -- TODO: Fully sort out ruby require/load mechanics -- -- require "json" -resolveRubyName :: ( Member (Modules address value) effects +resolveRubyName :: ( Member (Modules address) effects , Member (Resumable ResolutionError) effects ) => Text @@ -28,7 +28,7 @@ resolveRubyName name = do maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath -- load "/root/src/file.rb" -resolveRubyPath :: ( Member (Modules address value) effects +resolveRubyPath :: ( Member (Modules address) effects , Member (Resumable ResolutionError) effects ) => Text @@ -73,14 +73,14 @@ instance Evaluatable Require where rvalBox 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 doRequire :: ( AbstractValue address value effects - , Member (Modules address value) effects + , Member (Modules address) effects ) => M.ModulePath -> Evaluator address value effects (value, Environment address) doRequire path = do - result <- join <$> lookupModule path + result <- lookupModule path case result of - Nothing -> (,) (boolean True) . maybe lowerBound snd <$> load path + Nothing -> (,) (boolean True) . snd <$> load path Just (_, env) -> pure (boolean False, env) @@ -102,7 +102,7 @@ instance Evaluatable Load where doLoad :: ( AbstractValue address value effects , Member (Env address) effects - , Member (Modules address value) effects + , Member (Modules address) effects , Member (Resumable ResolutionError) effects , Member Trace effects ) @@ -112,7 +112,7 @@ doLoad :: ( AbstractValue address value effects doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' - importedEnv <- maybe lowerBound snd <$> load path' + importedEnv <- snd <$> load path' unless shouldWrap $ bindAll importedEnv pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index c218876e1..575229d04 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -35,7 +35,7 @@ toName = name . T.pack . unPath -- -- NB: TypeScript has a couple of different strategies, but the main one (and the -- only one we support) mimics Node.js. -resolveWithNodejsStrategy :: ( Member (Modules address value) effects +resolveWithNodejsStrategy :: ( Member (Modules address) effects , Member (Reader M.ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable ResolutionError) effects @@ -54,7 +54,7 @@ resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativ -- /root/src/moduleB.ts -- /root/src/moduleB/package.json (if it specifies a "types" property) -- /root/src/moduleB/index.ts -resolveRelativePath :: ( Member (Modules address value) effects +resolveRelativePath :: ( Member (Modules address) effects , Member (Reader M.ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable ResolutionError) effects @@ -82,7 +82,7 @@ resolveRelativePath relImportPath exts = do -- -- /root/node_modules/moduleB.ts, etc -- /node_modules/moduleB.ts, etc -resolveNonRelativePath :: ( Member (Modules address value) effects +resolveNonRelativePath :: ( Member (Modules address) effects , Member (Reader M.ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable ResolutionError) effects @@ -107,7 +107,7 @@ resolveNonRelativePath name exts = do notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript -- | Resolve a module name to a ModulePath. -resolveModule :: ( Member (Modules address value) effects +resolveModule :: ( Member (Modules address) effects , Member (Reader PackageInfo) effects , Member Trace effects ) @@ -133,13 +133,13 @@ javascriptExtensions = ["js"] evalRequire :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects - , Member (Modules address value) effects + , Member (Modules address) effects ) => M.ModulePath -> Name -> Evaluator address value effects value evalRequire modulePath alias = letrec' alias $ \addr -> do - importedEnv <- maybe lowerBound snd <$> require modulePath + importedEnv <- snd <$> require modulePath bindAll importedEnv unit <$ makeNamespace alias addr Nothing @@ -154,7 +154,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe lowerBound snd <$> require modulePath + importedEnv <- snd <$> require modulePath bindAll (renamed importedEnv) rvalBox unit where @@ -230,7 +230,7 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedExportFrom where eval (QualifiedExportFrom importPath exportSymbols) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe lowerBound snd <$> require modulePath + importedEnv <- snd <$> require modulePath -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index abccfcfcd..767889606 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -82,7 +82,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format - graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or entry point")) + graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module")) graphArgumentsParser = do graphType <- flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 2ba260cc2..1c2a2c560 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -44,6 +44,9 @@ data Options defaultOptions :: Options defaultOptions = Options (Just Warning) Nothing False +debugOptions :: Options +debugOptions = Options (Just Debug) Nothing False + defaultConfig :: Options -> IO Config defaultConfig options@Options{..} = do pid <- getProcessID diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 447a50572..cd2877ab6 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE GADTs, TypeOperators #-} +{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-} module Semantic.Graph ( runGraph +, runImportGraph , GraphType(..) , Graph , Vertex , GraphEff(..) +, ImportGraphEff(..) , style , parsePackage , withTermSpans @@ -17,15 +19,13 @@ module Semantic.Graph , resumingEnvironmentError ) where -import Prelude hiding (readFile) - -import Analysis.Abstract.Evaluating -import Analysis.Abstract.Graph +import Analysis.Abstract.Graph as Graph import Control.Abstract import Control.Monad.Effect (reinterpret) import Data.Abstract.Address 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 (Value, ValueError (..), runValueErrorWith) import Data.Graph @@ -39,35 +39,44 @@ import Semantic.Task as Task data GraphType = ImportGraph | CallGraph +type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, Functor, Ord1, Show1 ] + runGraph :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Task effs, Member Trace effs) => GraphType -> Bool -> Project -> Eff effs (Graph Vertex) -runGraph graphType includePackages project - | SomeAnalysisParser parser lang <- someAnalysisParser - (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do +runGraph ImportGraph _ project + | SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do package <- parsePackage parser project - let analyzeTerm = withTermSpans . case graphType of - ImportGraph -> id - CallGraph -> graphingTerms + fmap (Graph.moduleVertex . moduleInfo) <$> runImportGraph lang package +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 - analyze runGraphAnalysis (evaluatePackageWith lang analyzeModule analyzeTerm package) >>= extractGraph - where extractGraph result = case result of - (((_, graph), _), _) -> pure (simplify graph) - runGraphAnalysis - = run - . evaluating - . runIgnoringTrace - . resumingLoadError - . resumingUnspecialized - . resumingEnvironmentError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . resumingValueError - . runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _)) - . graphing + extractGraph (((_, graph), _), _) = simplify graph + runGraphAnalysis + = run + . runState lowerBound + . runFresh 0 + . runIgnoringTrace + . resumingLoadError + . resumingUnspecialized + . resumingEnvironmentError + . resumingEvalError + . resumingResolutionError + . resumingAddressError + . resumingValueError + . runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _)) + . graphing + . runReader (packageInfo package) + . runReader lowerBound + . fmap fst + . runState lowerBound + . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) + extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort 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 a = GraphEff @@ -76,7 +85,9 @@ newtype GraphEff address a = GraphEff , Env address , Allocator address (Value address (GraphEff address)) , Reader ModuleInfo - , Modules address (Value address (GraphEff address)) + , Modules address + -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47 + , State (ModuleTable (NonEmpty (Module (address, Environment address)))) , Reader Span , Reader PackageInfo , State (Graph Vertex) @@ -86,14 +97,80 @@ newtype GraphEff address a = GraphEff , Resumable EvalError , Resumable (EnvironmentError address) , Resumable (Unspecialized (Value address (GraphEff address))) - , Resumable (LoadError address (Value address (GraphEff address))) + , Resumable (LoadError address) , Trace , Fresh , State (Heap address Latest (Value address (GraphEff address))) - , State (ModuleTable (Maybe (address, Environment address))) ] a } + +runImportGraph :: ( Declarations term + , Evaluatable (Base term) + , FreeVariables term + , HasPrelude lang + , Member Task effs + , Member Trace effs + , Recursive term + ) + => Proxy lang + -> Package term + -> Eff effs (Graph (Module term)) +runImportGraph lang (package :: Package term) + -- Optimization for the common (when debugging) case of one-and-only-one module. + | [m :| []] <- toList (packageModules package) = vertex m <$ trace ("single module, skipping import graph computation for " <> modulePath (moduleInfo m)) + | otherwise = + let analyzeModule = graphingModuleInfo + extractGraph (((_, graph), _), _) = do + info <- graph + maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package)) + runImportGraphAnalysis + = run + . runState lowerBound + . runFresh 0 + . runIgnoringTrace + . resumingLoadError + . resumingUnspecialized + . resumingEnvironmentError + . resumingEvalError + . resumingResolutionError + . resumingAddressError + . resumingValueError + . runState lowerBound + . fmap fst + . runState lowerBound + . runModules (ModuleTable.modulePaths (packageModules package)) + . runTermEvaluator @_ @_ @(Value (Hole Precise) (ImportGraphEff term (Hole Precise))) + . runReader (packageInfo package) + . runReader lowerBound + in extractGraph <$> analyze runImportGraphAnalysis (evaluate @_ @_ @_ @_ @term lang analyzeModule id (ModuleTable.toPairs (packageModules package) >>= toList . snd)) + +newtype ImportGraphEff term address a = ImportGraphEff + { runImportGraphEff :: Eff '[ LoopControl address + , Return address + , Env address + , Allocator address (Value address (ImportGraphEff term address)) + , Reader ModuleInfo + , Reader Span + , Reader PackageInfo + , Modules address + -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47 + , State (ModuleTable (NonEmpty (Module (address, Environment address)))) + , State (Graph ModuleInfo) + , Resumable (ValueError address (ImportGraphEff term address)) + , Resumable (AddressError address (Value address (ImportGraphEff term address))) + , Resumable ResolutionError + , Resumable EvalError + , Resumable (EnvironmentError address) + , Resumable (Unspecialized (Value address (ImportGraphEff term address))) + , Resumable (LoadError address) + , Trace + , Fresh + , State (Heap address Latest (Value address (ImportGraphEff term address))) + ] a + } + + -- | Parse a list of files into a 'Package'. parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Trace effs) => Parser term -- ^ A parser. @@ -102,15 +179,15 @@ parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, M parsePackage parser project@Project{..} = do p <- parseModules parser resMap <- Task.resolutionMap project - let pkg = Package.fromModules n Nothing (length projectEntryPaths) p resMap - pkg <$ trace ("project: " <> show pkg) + let pkg = Package.fromModules n p resMap + pkg <$ trace ("project: " <> show (() <$ pkg)) where n = name (projectName project) -- | Parse all files in a project into 'Module's. - parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Eff effs [Module term] - parseModules parser = distributeFor (projectEntryPoints project <> projectFiles project) (WrapTask . parseModule project parser) + parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Project -> Eff effs [Module term] + parseModules parser Project{..} = distributeFor projectFiles (WrapTask . parseModule parser (Just projectRootDir)) -- | Parse a file into a 'Module'. parseModule :: (Member (Exc SomeException) effs, Member Task effs) => Project -> Parser term -> File -> Eff effs (Module term) @@ -132,8 +209,8 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr NotFoundError nameToResolve _ _ -> pure nameToResolve GoImportError pathToResolve -> pure [pathToResolve]) -resumingLoadError :: Member Trace effects => Evaluator address value (Resumable (LoadError address value) ': effects) a -> Evaluator address value effects a -resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing) +resumingLoadError :: (Member Trace effects, AbstractHole address) => Evaluator address value (Resumable (LoadError address) ': effects) a -> Evaluator address value effects a +resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> (hole, lowerBound)) resumingEvalError :: Member Trace effects => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 7b88ffdac..203ae97db 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -101,15 +101,12 @@ readBlobFromPath file = do readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project readProjectFromPaths maybeRoot path lang excludeDirs = do isDir <- isDirectory path - let (filterFun, entryPoints, rootDir) = if isDir - then (id, [], fromMaybe path maybeRoot) - else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot) + let rootDir = if isDir + then fromMaybe path maybeRoot + else fromMaybe (takeDirectory path) maybeRoot - - paths <- liftIO $ filterFun <$> findFilesInDir rootDir exts excludeDirs - let providedFiles = entryPoints <> (toFile <$> paths) - blobs <- traverse readBlobFromPath providedFiles - pure (Project rootDir blobs lang (filePath <$> entryPoints) excludeDirs) + paths <- liftIO $ findFilesInDir rootDir exts excludeDirs + pure $ Project rootDir (toFile <$> paths) lang excludeDirs where toFile path = File path lang exts = extensionsForLanguage lang diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 7b17a303a..277367372 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -31,6 +31,7 @@ module Semantic.Task , distributeFor , distributeFoldMap -- * Configuration +, debugOptions , defaultConfig , terminalFormatter , logfmtFormatter diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 94280abff..658171262 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -4,17 +4,21 @@ module Semantic.Util where import Analysis.Abstract.Caching import Analysis.Abstract.Collecting -import Analysis.Abstract.Evaluating import Control.Abstract import Control.Monad.Effect.Trace (runPrintingTrace) import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Value +import Data.Abstract.Module +import qualified Data.Abstract.ModuleTable as ModuleTable +import Data.Abstract.Package import Data.Abstract.Type import Data.Blob -import Data.Project import Data.Functor.Foldable +import Data.Graph (topologicalSort) import qualified Data.Language as Language +import Data.List (uncons) +import Data.Project import Data.Sum (weaken) import Data.Term import Language.Haskell.HsColour @@ -24,12 +28,14 @@ import Prologue hiding (weaken) import Semantic.Graph import Semantic.IO as IO import Semantic.Task +import System.FilePath.Posix (takeDirectory) import Text.Show (showListWith) import Text.Show.Pretty (ppShow) justEvaluating = runM - . evaluating + . runState lowerBound + . runFresh 0 . runPrintingTrace . fmap reassociate . runLoadError @@ -38,7 +44,6 @@ justEvaluating . runEnvironmentError . runEvalError . runAddressError - . runTermEvaluator @_ @Precise @(Value Precise (UtilEff _)) . runValueError newtype UtilEff address a = UtilEff @@ -47,7 +52,8 @@ newtype UtilEff address a = UtilEff , Env address , Allocator address (Value address (UtilEff address)) , Reader ModuleInfo - , Modules address (Value address (UtilEff address)) + , Modules address + , State (ModuleTable (NonEmpty (Module (address, Environment address)))) , Reader Span , Reader PackageInfo , Resumable (ValueError address (UtilEff address)) @@ -56,18 +62,18 @@ newtype UtilEff address a = UtilEff , Resumable (EnvironmentError address) , Resumable ResolutionError , Resumable (Unspecialized (Value address (UtilEff address))) - , Resumable (LoadError address (Value address (UtilEff address))) + , Resumable (LoadError address) , Trace , Fresh , State (Heap address Latest (Value address (UtilEff address))) - , State (ModuleTable (Maybe (address, Environment address))) , IO ] a } checking = runM @_ @IO - . evaluating + . runState (lowerBound @(Heap Monovariant All Type)) + . runFresh 0 . runPrintingTrace . runTermEvaluator @_ @Monovariant @Type . caching @[] @@ -81,18 +87,40 @@ checking . runAddressError . runTypeError -evalGoProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path -evalRubyProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path -evalPHPProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path -evalPythonProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path -evalJavaScriptProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser Language.JavaScript path -evalTypeScriptProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path +evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go +evalRubyProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby +evalPHPProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP +evalPythonProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python +evalJavaScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser Language.JavaScript +evalTypeScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript -typecheckGoFile path = checking =<< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go path +typecheckGoFile = checking <=< evaluateProjectWithCaching (Proxy :: Proxy 'Language.Go) goParser Language.Go --- Evaluate a project, starting at a single entrypoint. -evaluateProject proxy parser lang path = evaluatePackageWith proxy id withTermSpans . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser) -evaluateProjectWithCaching proxy parser lang path = evaluatePackageWith proxy convergingModules (withTermSpans . cachingTerms) . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser) +-- Evaluate a project consisting of the listed paths. +evaluateProject proxy parser lang paths = runTaskWithOptions debugOptions $ do + package <- fmap quieterm <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) (flip File lang <$> paths) lang []) + modules <- topologicalSort <$> runImportGraph proxy package + trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules) + pure (runTermEvaluator @_ @_ @(Value Precise (UtilEff Precise)) + (runReader (packageInfo package) + (runReader (lowerBound @Span) + -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47 + (fmap fst + (runState (lowerBound @(ModuleTable (NonEmpty (Module (Precise, Environment Precise))))) + (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) + (evaluate proxy id withTermSpans modules))))))) + +evaluateProjectWithCaching proxy parser lang path = runTaskWithOptions debugOptions $ do + project <- readProject Nothing path lang [] + package <- fmap quieterm <$> parsePackage parser project + modules <- topologicalSort <$> runImportGraph proxy package + pure (runReader (packageInfo package) + (runReader (lowerBound @Span) + -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47 + (fmap fst + (runState (lowerBound @(ModuleTable (NonEmpty (Module (Monovariant, Environment Monovariant))))) + (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) + (evaluate proxy id withTermSpans modules)))))) parseFile :: Parser term -> FilePath -> IO term diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 08a4ebf3c..415ac2a78 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -2,6 +2,7 @@ module Analysis.Go.Spec (spec) where import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable (EvalError(..)) +import qualified Data.Abstract.ModuleTable as ModuleTable import qualified Data.Language as Language import qualified Language.Go.Assignment as Go import SpecHelpers @@ -9,20 +10,24 @@ import SpecHelpers spec :: Spec spec = parallel $ do - describe "evaluates Go" $ do + describe "Go" $ do it "imports and wildcard imports" $ do - ((Right [(_, env)], state), _) <- evaluate "main.go" - Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ] - - (derefQName (heap state) ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"]) + ((res, heap), _) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"] + case ModuleTable.lookup "main.go" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ] + (derefQName heap ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"]) + other -> expectationFailure (show other) it "imports with aliases (and side effects only)" $ do - ((Right [(_, env)], state), _) <- evaluate "main1.go" - Env.names env `shouldBe` [ "f", "main" ] - - (derefQName (heap state) ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"]) + ((res, heap), _) <- evaluate ["main1.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"] + case ModuleTable.lookup "main1.go" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + Env.names env `shouldBe` [ "f", "main" ] + (derefQName heap ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"]) + other -> expectationFailure (show other) where fixtures = "test/fixtures/go/analysis/" - evaluate entry = evalGoProject (fixtures <> entry) - evalGoProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path + evaluate = evalGoProject . map (fixtures <>) + evalGoProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index d6bb2e589..7da92c101 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -4,6 +4,7 @@ import Control.Abstract import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable (EvalError(..)) import qualified Data.Language as Language +import qualified Data.Abstract.ModuleTable as ModuleTable import qualified Language.PHP.Assignment as PHP import SpecHelpers @@ -12,24 +13,33 @@ spec :: Spec spec = parallel $ do describe "PHP" $ do it "evaluates include and require" $ do - ((Right [(res, env)], state), _) <- evaluate "main.php" - res `shouldBe` unit - Env.names env `shouldBe` [ "bar", "foo" ] + ((res, heap), _) <- evaluate ["main.php", "foo.php", "bar.php"] + case ModuleTable.lookup "main.php" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + heapLookupAll addr heap `shouldBe` Just [unit] + Env.names env `shouldBe` [ "bar", "foo" ] + other -> expectationFailure (show other) it "evaluates include_once and require_once" $ do - ((Right [(res, env)], state), _) <- evaluate "main_once.php" - res `shouldBe` unit - Env.names env `shouldBe` [ "bar", "foo" ] + ((res, heap), _) <- evaluate ["main_once.php", "foo.php", "bar.php"] + case ModuleTable.lookup "main_once.php" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + heapLookupAll addr heap `shouldBe` Just [unit] + Env.names env `shouldBe` [ "bar", "foo" ] + other -> expectationFailure (show other) it "evaluates namespaces" $ do - ((Right [(_, env)], state), _) <- evaluate "namespaces.php" - Env.names env `shouldBe` [ "Foo", "NS1" ] + ((res, heap), _) <- evaluate ["namespaces.php"] + case ModuleTable.lookup "namespaces.php" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + Env.names env `shouldBe` [ "Foo", "NS1" ] - (derefQName (heap state) ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) - (derefQName (heap state) ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) - (derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) + (derefQName heap ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) + (derefQName heap ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) + (derefQName heap ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) + other -> expectationFailure (show other) where fixtures = "test/fixtures/php/analysis/" - evaluate entry = evalPHPProject (fixtures <> entry) - evalPHPProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path + evaluate = evalPHPProject . map (fixtures <>) + evalPHPProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 753da4932..cceabf849 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -2,8 +2,8 @@ module Analysis.Python.Spec (spec) where import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable (EvalError(..)) +import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Value -import Data.Map import qualified Language.Python.Assignment as Python import qualified Data.Language as Language @@ -12,38 +12,52 @@ import SpecHelpers spec :: Spec spec = parallel $ do - describe "evaluates Python" $ do + describe "Python" $ do it "imports" $ do - ((Right [(_, env)], state), _) <- evaluate "main.py" - Env.names env `shouldContain` [ "a", "b" ] + ((res, heap), _) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"] + case ModuleTable.lookup "main.py" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + Env.names env `shouldContain` [ "a", "b" ] - (derefQName (heap state) ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"]) - (derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"]) - (derefQName (heap state) ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"]) + (derefQName heap ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"]) + (derefQName heap ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"]) + (derefQName heap ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"]) + other -> expectationFailure (show other) it "imports with aliases" $ do - ((Right [(_, env)], _), _) <- evaluate "main1.py" - Env.names env `shouldContain` [ "b", "e" ] + ((res, _), _) <- evaluate ["main1.py", "a.py", "b/__init__.py", "b/c.py"] + case ModuleTable.lookup "main1.py" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> Env.names env `shouldContain` [ "b", "e" ] + other -> expectationFailure (show other) it "imports using 'from' syntax" $ do - ((Right [(_, env)], _), _) <- evaluate "main2.py" - Env.names env `shouldContain` [ "bar", "foo" ] + ((res, _), _) <- evaluate ["main2.py", "a.py", "b/__init__.py", "b/c.py"] + case ModuleTable.lookup "main2.py" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ] + other -> expectationFailure (show other) it "imports with relative syntax" $ do - ((Right [(_, env)], state), _) <- evaluate "main3.py" - Env.names env `shouldContain` [ "utils" ] - (derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) + ((res, heap), _) <- evaluate ["main3.py", "c/__init__.py", "c/utils.py"] + case ModuleTable.lookup "main3.py" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + Env.names env `shouldContain` [ "utils" ] + (derefQName heap ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) + other -> expectationFailure (show other) it "subclasses" $ do - ((res, _), _) <- evaluate "subclass.py" - fmap fst <$> res `shouldBe` Right [String "\"bar\""] + ((res, heap), _) <- evaluate ["subclass.py"] + case ModuleTable.lookup "subclass.py" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"bar\""] + other -> expectationFailure (show other) it "handles multiple inheritance left-to-right" $ do - ((res, _), _) <- evaluate "multiple_inheritance.py" - fmap fst <$> res `shouldBe` Right [String "\"foo!\""] + ((res, heap), _) <- evaluate ["multiple_inheritance.py"] + case ModuleTable.lookup "multiple_inheritance.py" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"foo!\""] + other -> expectationFailure (show other) where ns n = Just . Latest . Last . Just . Namespace n fixtures = "test/fixtures/python/analysis/" - evaluate entry = evalPythonProject (fixtures <> entry) - evalPythonProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path + evaluate = evalPythonProject . map (fixtures <>) + evalPythonProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 72cb00929..e935e437e 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -3,12 +3,11 @@ module Analysis.Ruby.Spec (spec) where import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable import Data.Abstract.Value as Value +import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Number as Number import Data.AST import Control.Monad.Effect (SomeExc(..)) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map -import Data.Map.Monoidal as Map import Data.Sum import qualified Language.Ruby.Assignment as Ruby import qualified Data.Language as Language @@ -20,61 +19,89 @@ spec :: Spec spec = parallel $ do describe "Ruby" $ do it "evaluates require_relative" $ do - ((Right [(res, env)], state), _) <- evaluate "main.rb" - res `shouldBe` Value.Integer (Number.Integer 1) - Env.names env `shouldContain` ["foo"] + ((res, heap), _) <- evaluate ["main.rb", "foo.rb"] + case ModuleTable.lookup "main.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)] + Env.names env `shouldContain` [ "foo" ] + other -> expectationFailure (show other) it "evaluates load" $ do - ((Right [(_, env)], _), _) <- evaluate "load.rb" - Env.names env `shouldContain` ["foo"] + ((res, heap), _) <- evaluate ["load.rb", "foo.rb"] + case ModuleTable.lookup "load.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)] + Env.names env `shouldContain` [ "foo" ] + other -> expectationFailure (show other) it "evaluates load with wrapper" $ do - ((res, state), _) <- evaluate "load-wrap.rb" + ((res, _), _) <- evaluate ["load-wrap.rb", "foo.rb"] res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo"))) it "evaluates subclass" $ do - ((Right [(res, env)], state), _) <- evaluate "subclass.rb" - res `shouldBe` String "\"\"" - Env.names env `shouldContain` [ "Bar", "Foo" ] + ((res, heap), _) <- evaluate ["subclass.rb"] + case ModuleTable.lookup "subclass.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + heapLookupAll addr heap `shouldBe` Just [String "\"\""] + Env.names env `shouldContain` [ "Bar", "Foo" ] - (derefQName (heap state) ("Bar" :| []) env >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) + (derefQName heap ("Bar" :| []) env >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) + other -> expectationFailure (show other) it "evaluates modules" $ do - ((Right [(res, env)], state), _) <- evaluate "modules.rb" - res `shouldBe` String "\"\"" - Env.names env `shouldContain` [ "Bar" ] + ((res, heap), _) <- evaluate ["modules.rb"] + case ModuleTable.lookup "modules.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + heapLookupAll addr heap `shouldBe` Just [String "\"\""] + Env.names env `shouldContain` [ "Bar" ] + other -> expectationFailure (show other) it "handles break correctly" $ do - ((res, _), _) <- evaluate "break.rb" - fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 3)] + ((res, heap), _) <- evaluate ["break.rb"] + case ModuleTable.lookup "break.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] + other -> expectationFailure (show other) - it "handles break correctly" $ do - ((res, _), _) <- evaluate "next.rb" - fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 8)] + it "handles next correctly" $ do + ((res, heap), _) <- evaluate ["next.rb"] + case ModuleTable.lookup "next.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 8)] + other -> expectationFailure (show other) it "calls functions with arguments" $ do - ((res, _), _) <- evaluate "call.rb" - fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 579)] + ((res, heap), _) <- evaluate ["call.rb"] + case ModuleTable.lookup "call.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 579)] + other -> expectationFailure (show other) it "evaluates early return statements" $ do - ((res, _), _) <- evaluate "early-return.rb" - fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 123)] + ((res, heap), _) <- evaluate ["early-return.rb"] + case ModuleTable.lookup "early-return.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)] + other -> expectationFailure (show other) it "has prelude" $ do - ((res, _), _) <- evaluate "preluded.rb" - fmap fst <$> res `shouldBe` Right [String "\"\""] + ((res, heap), _) <- evaluate ["preluded.rb"] + case ModuleTable.lookup "preluded.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"\""] + other -> expectationFailure (show other) it "evaluates __LINE__" $ do - ((res, _), _) <- evaluate "line.rb" - fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 4)] + ((res, heap), _) <- evaluate ["line.rb"] + case ModuleTable.lookup "line.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)] + other -> expectationFailure (show other) it "resolves builtins used in the prelude" $ do - ((res, _), traces) <- evaluate "puts.rb" - fmap fst <$> res `shouldBe` Right [Unit] - traces `shouldContain` [ "\"hello\"" ] + ((res, heap), traces) <- evaluate ["puts.rb"] + case ModuleTable.lookup "puts.rb" <$> res of + Right (Just (Module _ (addr, env) :| [])) -> do + heapLookupAll addr heap `shouldBe` Just [Unit] + traces `shouldContain` [ "\"hello\"" ] + other -> expectationFailure (show other) where ns n = Just . Latest . Last . Just . Namespace n fixtures = "test/fixtures/ruby/analysis/" - evaluate entry = evalRubyProject (fixtures <> entry) - evalRubyProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path + evaluate = evalRubyProject . map (fixtures <>) + evalRubyProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 7dca4e0aa..2f422ded3 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -3,41 +3,50 @@ module Analysis.TypeScript.Spec (spec) where import Control.Arrow ((&&&)) import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import qualified Language.TypeScript.Assignment as TypeScript import Data.Abstract.Value as Value import Data.Abstract.Number as Number +import qualified Data.Abstract.ModuleTable as ModuleTable import qualified Data.Language as Language +import qualified Data.List.NonEmpty as NonEmpty import Data.Sum - import SpecHelpers spec :: Spec spec = parallel $ do - describe "evaluates TypeScript" $ do + describe "TypeScript" $ do it "imports with aliased symbols" $ do - ((Right [(_, env)], _), _) <- evaluate "main.ts" - Env.names env `shouldBe` [ "bar", "quz" ] + ((res, _), _) <- evaluate ["main.ts", "foo.ts", "a.ts", "foo/b.ts"] + case ModuleTable.lookup "main.ts" <$> res of + Right (Just (Module _ (_, env) :| [])) -> Env.names env `shouldBe` [ "bar", "quz" ] + other -> expectationFailure (show other) it "imports with qualified names" $ do - ((Right [(_, env)], state), _) <- evaluate "main1.ts" - Env.names env `shouldBe` [ "b", "z" ] + ((res, heap), _) <- evaluate ["main1.ts", "foo.ts", "a.ts"] + case ModuleTable.lookup "main1.ts" <$> res of + Right (Just (Module _ (_, env) :| [])) -> do + Env.names env `shouldBe` [ "b", "z" ] - (derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) - (derefQName (heap state) ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) + (derefQName heap ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) + (derefQName heap ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) + other -> expectationFailure (show other) it "side effect only imports" $ do - ((res, _), _) <- evaluate "main2.ts" - fmap snd <$> res `shouldBe` Right [lowerBound] + ((res, _), _) <- evaluate ["main2.ts", "a.ts", "foo.ts"] + case ModuleTable.lookup "main2.ts" <$> res of + Right (Just (Module _ (_, env) :| [])) -> env `shouldBe` lowerBound + other -> expectationFailure (show other) it "fails exporting symbols not defined in the module" $ do - ((res, _), _) <- evaluate "bad-export.ts" + ((res, _), _) <- evaluate ["bad-export.ts", "pip.ts", "a.ts", "foo.ts"] res `shouldBe` Left (SomeExc (inject @EvalError (ExportError "foo.ts" (name "pip")))) it "evaluates early return statements" $ do - ((res, _), _) <- evaluate "early-return.ts" - fmap fst <$> res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] + ((res, heap), _) <- evaluate ["early-return.ts"] + case ModuleTable.lookup "early-return.ts" <$> res of + Right (Just (Module _ (addr, _) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Float (Number.Decimal 123.0)] + other -> expectationFailure (show other) where fixtures = "test/fixtures/typescript/analysis/" - evaluate entry = evalTypeScriptProject (fixtures <> entry) - evalTypeScriptProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path + evaluate = evalTypeScriptProject . map (fixtures <>) + evalTypeScriptProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index a0f21fa8c..0d54f31b9 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -4,7 +4,6 @@ module Control.Abstract.Evaluator.Spec , SpecEff(..) ) where -import Analysis.Abstract.Evaluating (evaluating) import Control.Abstract import Data.Abstract.Module import qualified Data.Abstract.Number as Number @@ -30,14 +29,15 @@ spec = parallel $ do evaluate = runM - . evaluating @Precise @Val - . runReader (PackageInfo (name "test") Nothing mempty) + . runState (lowerBound @(Heap Precise Latest Val)) + . runFresh 0 + . runReader (PackageInfo (name "test") mempty) . runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs") . fmap reassociate . runValueError . runEnvironmentError . runAddressError - . runAllocator + . runAllocator @Precise @_ @Val . (>>= deref . fst) . runEnv lowerBound . runReturn @@ -59,7 +59,6 @@ newtype SpecEff a = SpecEff , Reader PackageInfo , Fresh , State (Heap Precise Latest Val) - , State (ModuleTable (Maybe (Precise, Environment Precise))) , IO ] a } diff --git a/test/Doctests.hs b/test/Doctests.hs index 395677757..8aa098b51 100644 --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -9,6 +9,7 @@ defaultFiles = [ "src/Data/Abstract/Address.hs" , "src/Data/Abstract/Environment.hs" , "src/Data/Abstract/Name.hs" + , "src/Data/Graph.hs" , "src/Data/Range.hs" , "src/Data/Semigroup/App.hs" ] diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 79db79118..b4823e846 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -9,12 +9,10 @@ module SpecHelpers , derefQName , verbatim , TermEvaluator(..) -, TestEff(..) , Verbatim(..) +, toList ) where -import Analysis.Abstract.Evaluating -import Analysis.Abstract.Evaluating as X (EvaluatingState(..)) import Control.Abstract import Control.Arrow ((&&&)) import Control.Monad.Effect.Trace as X (runIgnoringTrace, runReturningTrace) @@ -24,6 +22,7 @@ import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables as X import Data.Abstract.Heap as X +import Data.Abstract.Module as X import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Abstract.Name as X import Data.Abstract.Value (Value(..), ValueError, runValueError) @@ -33,6 +32,7 @@ import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Lazy (toStrict) import Data.Project as X import Data.Proxy as X +import Data.Foldable (toList) import Data.Functor.Listable as X import Data.Language as X import Data.List.NonEmpty as X (NonEmpty(..)) @@ -81,38 +81,39 @@ readFilePair :: Both FilePath -> IO BlobPair readFilePair paths = let paths' = fmap file paths in runBothWith IO.readFilePair paths' -testEvaluating :: TermEvaluator term Precise - Val - '[ Resumable (ValueError Precise TestEff) - , Resumable (AddressError Precise Val) - , Resumable EvalError, Resumable (EnvironmentError Precise) - , Resumable ResolutionError - , Resumable (Unspecialized Val) - , Resumable (LoadError Precise Val) - , Fresh - , State (Heap Precise Latest Val) - , State (ModuleTable (Maybe (Precise, Environment Precise))) - , Trace - ] - [(Precise, Environment Precise)] - -> ((Either - (SomeExc - (Data.Sum.Sum - '[ ValueError Precise TestEff - , AddressError Precise Val - , EvalError - , EnvironmentError Precise - , ResolutionError - , Unspecialized Val - , LoadError Precise Val - ])) - [(Value Precise TestEff, Environment Precise)], - EvaluatingState Precise Val), - [String]) +type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise)) + , Resumable (AddressError Precise Val) + , Resumable EvalError, Resumable (EnvironmentError Precise) + , Resumable ResolutionError + , Resumable (Unspecialized Val) + , Resumable (LoadError Precise) + , Trace + , Fresh + , State (Heap Precise Latest Val) + , IO + ] +type TestEvaluatingErrors = '[ ValueError Precise (UtilEff Precise) + , AddressError Precise Val + , EvalError + , EnvironmentError Precise + , ResolutionError + , Unspecialized Val + , LoadError Precise + ] +testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (Precise, Environment Precise)))) + -> IO + ( ( Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors)) + (ModuleTable (NonEmpty (Module (Precise, Environment Precise)))) + , Heap Precise Latest Val + ) + , [String] + ) testEvaluating - = run + = runM + . fmap (\ ((res, traces), heap) -> ((res, heap), traces)) + . runState lowerBound + . runFresh 0 . runReturningTrace - . evaluating . fmap reassociate . runLoadError . runUnspecialized @@ -120,37 +121,10 @@ testEvaluating . runEnvironmentError . runEvalError . runAddressError - . runValueError - . (>>= traverse deref1) - . runTermEvaluator @_ @_ @Val + . runValueError @_ @Precise @(UtilEff Precise) -type Val = Value Precise TestEff -newtype TestEff a = TestEff - { runTestEff :: Eff '[ LoopControl Precise - , Return Precise - , Env Precise - , Allocator Precise Val - , Reader ModuleInfo - , Modules Precise Val - , Reader Span - , Reader PackageInfo - , Resumable (ValueError Precise TestEff) - , Resumable (AddressError Precise Val) - , Resumable EvalError - , Resumable (EnvironmentError Precise) - , Resumable ResolutionError - , Resumable (Unspecialized Val) - , Resumable (LoadError Precise Val) - , Fresh - , State (Heap Precise Latest Val) - , State (ModuleTable (Maybe (Precise, Environment Precise))) - , Trace - ] a - } +type Val = Value Precise (UtilEff Precise) -deref1 (ptr, env) = runAllocator $ do - val <- deref ptr - pure (val, env) deNamespace :: Value Precise term -> Maybe (Name, [Name]) deNamespace (Namespace name scope) = Just (name, Env.names scope)