github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into higher-order-effects

Browse Source
This commit is contained in:
Rob Rix 2018-06-26 15:14:28 -04:00
commit a236328056
28 changed files with 611 additions and 431 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic.cabal
View File

@ -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

42
src/Analysis/Abstract/Graph.hs
View File

@ -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
@ -67,6 +69,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
)
@ -74,20 +77,39 @@ 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
. ( Effects effects
, 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 = eavesdrop @(Modules address value) (\ m -> case m of
Load path -> moduleInclusion (moduleVertex (ModuleInfo path))
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path))
_ -> pure ())
(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)))
eavesdrop @(Modules address) (\ m -> case m of
Load path -> moduleInclusion (moduleVertex (ModuleInfo path))
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path))
_ -> pure ())
(recur m)
-- | Add vertices to the graph for imported modules.
graphingModuleInfo :: forall term address value effects a
. ( Effects effects
, 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))
eavesdrop @(Modules address) (\ eff -> case eff of
Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
_ -> pure ())
(recur m)
packageVertex :: PackageInfo -> Vertex
@ -130,7 +152,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' . (<>)

119
src/Control/Abstract/Modules.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators #-}
module Control.Abstract.Modules
( lookupModule
, resolve
@ -22,120 +22,93 @@ 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 (Environment address, 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 (Environment address, 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 (Environment address, address))
require :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Environment address, 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 (Environment address, address))
load :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Environment address, address)
load path = sendModules (Load path)
data Modules address value (m :: * -> *) return where
Load :: ModulePath -> Modules address value m (Maybe (Environment address, address))
Lookup :: ModulePath -> Modules address value m (Maybe (Maybe (Environment address, address)))
Resolve :: [FilePath] -> Modules address value m (Maybe ModulePath)
List :: FilePath -> Modules address value m [ModulePath]
data Modules address (m :: * -> *) return where
Load :: ModulePath -> Modules address m (Environment address, address)
Lookup :: ModulePath -> Modules address m (Maybe (Environment address, address))
Resolve :: [FilePath] -> Modules address m (Maybe ModulePath)
List :: FilePath -> Modules address m [ModulePath]
instance Effect (Modules address value) where
instance Effect (Modules address) where
handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k)
handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k)
handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k)
handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k)
sendModules :: Member (Modules address value) effects => Modules address value (Eff effects) return -> Evaluator address value effects return
sendModules :: Member (Modules address) effects => Modules address (Eff effects) 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 (Environment address, address)))) effects
, Member Trace effects
, Effects effects
runModules :: ( Effects effects
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
, Member (State (ModuleTable (NonEmpty (Module (Environment address, address))))) effects
, Member (Resumable (LoadError address)) effects
)
=> (Module term -> Evaluator address value (Modules address value ': effects) (Environment address, 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 (Environment address, address)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, address)))
getModuleTable = get
cacheModule :: Member (State (ModuleTable (Maybe (Environment address, address)))) effects => ModulePath -> Maybe (Environment address, address) -> Evaluator address value effects (Maybe (Environment address, 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 (Environment address, address))))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module (Environment address, address))))
askModuleTable = get
newtype Merging m address value = Merging { runMerging :: m (Maybe (Environment address, address)) }
newtype Merging address = Merging { runMerging :: (Environment address, 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, _) (env2, v) = (mergeEnvs env1 env2, v)
instance Applicative m => Monoid (Merging m address value) where
mappend = (<>)
mempty = Merging (pure Nothing)
instance Semigroup (Merging address) where
Merging (env1, _) <> Merging (env2, addr) = Merging (mergeEnvs env1 env2, addr)
-- | 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 (Environment address, address))
data LoadError address resume where
ModuleNotFound :: ModulePath -> LoadError address (Environment address, 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 (Environment address, address))
moduleNotFound = throwResumable . ModuleNotFound @address @value
moduleNotFound :: Member (Resumable (LoadError address)) effects => ModulePath -> Evaluator address value effects (Environment address, address)
moduleNotFound = throwResumable . ModuleNotFound
runLoadError :: (Effectful (m address value), Effects effects) => m address value (Resumable (LoadError address value) ': effects) a -> m address value effects (Either (SomeExc (LoadError address value)) a)
runLoadError :: (Effectful (m address value), Effects effects) => m address value (Resumable (LoadError address) ': effects) a -> m address value effects (Either (SomeExc (LoadError address)) a)
runLoadError = runResumable
runLoadErrorWith :: (Effectful (m address value), Effects effects) => (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), Effects effects) => (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

126
src/Data/Abstract/Evaluatable.hs
View File

@ -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
@ -50,7 +50,7 @@ class Show1 constr => Evaluatable constr where
, Member (Env address) effects
, Member (Exc (LoopControl address)) effects
, Member (Exc (Return address)) effects
, Member (Modules address value) effects
, Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
@ -64,75 +64,59 @@ 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
, Effects outer
, 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 (Environment address, address)))) outer
, Member Trace outer
, Recursive term
, Reducer value (Cell address value)
, ValueRoots address value
, inner ~ (Exc (LoopControl address) ': Exc (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 [(Environment address, 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
, Effects effects
, Evaluatable (Base term)
, Foldable (Cell address)
, FreeVariables term
, HasPrelude lang
, Member Fresh effects
, Member (Modules address) effects
, Member (State (ModuleTable (NonEmpty (Module (Environment address, 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 ~ (Exc (LoopControl address) ': Exc (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 (Environment address, 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'' (Environment address, address)
evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do
addr <- box unit -- TODO don't *always* allocate - use maybeM instead
(env, ptr) <- fromMaybe (lowerBound, addr) <$> require m
bindAll env
maybe (pure ptr) ((`call` []) <=< deref <=< variable) sym
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 ()

11
src/Data/Abstract/Module.hs
View File

@ -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

4
src/Data/Abstract/ModuleTable.hs
View File

@ -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

21
src/Data/Abstract/Package.hs
View File

@ -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)

75
src/Data/Graph.hs
View File

@ -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 . fst
. 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

1
src/Data/Project.hs
View File

@ -9,7 +9,6 @@ data Project = Project
{ projectRootDir :: FilePath
, projectFiles :: [File]
, projectLanguage :: Language
, projectEntryPoints :: [File]
, projectExcludeDirs :: [FilePath]
}
deriving (Eq, Ord, Show)

6
src/Language/Go/Syntax.hs
View File

@ -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 fst <$> require path
importedEnv <- fst <$> 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 fst <$> require p
importedEnv <- fst <$> require p
bindAll importedEnv
makeNamespace alias addr Nothing
rvalBox unit

9
src/Language/PHP/Syntax.hs
View File

@ -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 (Environment address, address)))
-> (ModulePath -> Evaluator address value effects (Environment address, 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
(importedEnv, v) <- fromMaybe (lowerBound, unitPtr) <$> f path
(importedEnv, v) <- f path
bindAll importedEnv
pure (Rval v)

10
src/Language/Python/Syntax.hs
View File

@ -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 fst <$> require path
importedEnv <- fst <$> 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 fst <$> require path
importedEnv <- fst <$> 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 fst <$> require path
importedEnv <- fst <$> require path
bindAll importedEnv
unit <$ makeNamespace alias addr Nothing)

14
src/Language/Ruby/Syntax.hs
View File

@ -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 (Environment address, value)
doRequire path = do
result <- join <$> lookupModule path
result <- lookupModule path
case result of
Nothing -> flip (,) (boolean True) . maybe lowerBound fst <$> load path
Nothing -> flip (,) (boolean True) . fst <$> load path
Just (env, _) -> pure (env, boolean False)
@ -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 fst <$> load path'
importedEnv <- fst <$> 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

16
src/Language/TypeScript/Syntax.hs
View File

@ -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 fst <$> require modulePath
importedEnv <- fst <$> 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 fst <$> require modulePath
importedEnv <- fst <$> 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 fst <$> require modulePath
importedEnv <- fst <$> 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

2
src/Semantic/CLI.hs
View File

@ -83,7 +83,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")

3
src/Semantic/Config.hs
View File

@ -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

145
src/Semantic/Graph.hs
View File

@ -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,13 +19,13 @@ module Semantic.Graph
, resumingEnvironmentError
) where
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
@ -38,35 +40,44 @@ import Semantic.Task as Task
data GraphType = ImportGraph | CallGraph
type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, Functor, Ord1, Show1 ]
runGraph :: (Member Distribute effs, Member Files 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
@ -75,7 +86,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 (Environment address, address))))
, Reader Span
, Reader PackageInfo
, State (Graph Vertex)
@ -85,14 +98,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 (Environment address, 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 '[ Exc (LoopControl address)
, Exc (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 (Environment address, 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 effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs)
=> Parser term -- ^ A parser.
@ -101,15 +180,15 @@ parsePackage :: (Member Distribute effs, Member Files effs, Member Resolution ef
parsePackage parser project@Project{..} = do
p <- parseModules parser project
resMap <- Task.resolutionMap project
let pkg = Package.fromModules n Nothing (length projectEntryPoints) 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 effs, Member Files effs, Member Task effs) => Parser term -> Project -> Eff effs [Module term]
parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (parseModule parser (Just projectRootDir))
parseModules parser Project{..} = distributeFor projectFiles (parseModule parser (Just projectRootDir))
-- | Parse a file into a 'Module'.
parseModule :: (Member Files effs, Member Task effs) => Parser term -> Maybe FilePath -> File -> Eff effs (Module term)
@ -130,8 +209,8 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr
NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve])
resumingLoadError :: (Member Trace effects, Effects 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, Effects effects) => Evaluator address value (Resumable (LoadError address) ': effects) a -> Evaluator address value effects a
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> (lowerBound, hole))
resumingEvalError :: (Member Trace effects, Effects effects) => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a
resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of

10
src/Semantic/IO.hs
View File

@ -100,12 +100,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
pure $ Project rootDir (toFile <$> paths) lang entryPoints excludeDirs
paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
pure $ Project rootDir (toFile <$> paths) lang excludeDirs
where
toFile path = File path lang
exts = extensionsForLanguage lang

1
src/Semantic/Task.hs
View File

@ -30,6 +30,7 @@ module Semantic.Task
, distributeFor
, distributeFoldMap
-- * Configuration
, debugOptions
, defaultConfig
, terminalFormatter
, logfmtFormatter

64
src/Semantic/Util.hs
View File

@ -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
. runEvalError
. runResolutionError
. 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 (Environment address, address))))
, Reader Span
, Reader PackageInfo
, Resumable (ValueError address (UtilEff address))
@ -56,18 +62,18 @@ newtype UtilEff address a = UtilEff
, Resumable EvalError
, Resumable (EnvironmentError address)
, 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 (Environment address, address)))
, Lift 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 (Environment Precise, 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 (Environment Monovariant, Monovariant)))))
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
(evaluate proxy id withTermSpans modules))))))
parseFile :: Parser term -> FilePath -> IO term

27
test/Analysis/Go/Spec.hs
View File

@ -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
(_, (state, Right [(env, _)])) <- evaluate "main.go"
Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ]
(derefQName (heap state) ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"])
(_, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
case ModuleTable.lookup "main.go" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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
(_, (state, Right [(env, _)])) <- evaluate "main1.go"
Env.names env `shouldBe` [ "f", "main" ]
(derefQName (heap state) ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"])
(_, (heap, res)) <- evaluate ["main1.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
case ModuleTable.lookup "main1.go" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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

36
test/Analysis/PHP/Spec.hs
View File

@ -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 [(env, res)])) <- evaluate "main.php"
res `shouldBe` unit
Env.names env `shouldBe` [ "bar", "foo" ]
(_, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"]
case ModuleTable.lookup "main.php" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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 [(env, res)])) <- evaluate "main_once.php"
res `shouldBe` unit
Env.names env `shouldBe` [ "bar", "foo" ]
(_, (heap, res)) <- evaluate ["main_once.php", "foo.php", "bar.php"]
case ModuleTable.lookup "main_once.php" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [unit]
Env.names env `shouldBe` [ "bar", "foo" ]
other -> expectationFailure (show other)
it "evaluates namespaces" $ do
(_, (state, Right [(env, _)])) <- evaluate "namespaces.php"
Env.names env `shouldBe` [ "Foo", "NS1" ]
(_, (heap, res)) <- evaluate ["namespaces.php"]
case ModuleTable.lookup "namespaces.php" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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

54
test/Analysis/Python/Spec.hs
View File

@ -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
(_, (state, Right [(env, _)])) <- evaluate "main.py"
Env.names env `shouldContain` [ "a", "b" ]
(_, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]
case ModuleTable.lookup "main.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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 _ (env, addr) :| [])) -> 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 _ (env, addr) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ]
other -> expectationFailure (show other)
it "imports with relative syntax" $ do
(_, (state, Right [(env, _)])) <- evaluate "main3.py"
Env.names env `shouldContain` [ "utils" ]
(derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
(_, (heap, res)) <- evaluate ["main3.py", "c/__init__.py", "c/utils.py"]
case ModuleTable.lookup "main3.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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 snd <$> res `shouldBe` Right [String "\"bar\""]
(_, (heap, res)) <- evaluate ["subclass.py"]
case ModuleTable.lookup "subclass.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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 snd <$> res `shouldBe` Right [String "\"foo!\""]
(_, (heap, res)) <- evaluate ["multiple_inheritance.py"]
case ModuleTable.lookup "multiple_inheritance.py" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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

93
test/Analysis/Ruby/Spec.hs
View File

@ -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 [(env, res)])) <- evaluate "main.rb"
res `shouldBe` Value.Integer (Number.Integer 1)
Env.names env `shouldContain` ["foo"]
(_, (heap, res)) <- evaluate ["main.rb", "foo.rb"]
case ModuleTable.lookup "main.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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"]
(_, (heap, res)) <- evaluate ["load.rb", "foo.rb"]
case ModuleTable.lookup "load.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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)) <- evaluate "load-wrap.rb"
(_, (_, res)) <- evaluate ["load-wrap.rb", "foo.rb"]
res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
it "evaluates subclass" $ do
(_, (state, Right [(env, res)])) <- evaluate "subclass.rb"
res `shouldBe` String "\"<bar>\""
Env.names env `shouldContain` [ "Bar", "Foo" ]
(_, (heap, res)) <- evaluate ["subclass.rb"]
case ModuleTable.lookup "subclass.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [String "\"<bar>\""]
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
(_, (state, Right [(env, res)])) <- evaluate "modules.rb"
res `shouldBe` String "\"<hello>\""
Env.names env `shouldContain` [ "Bar" ]
(_, (heap, res)) <- evaluate ["modules.rb"]
case ModuleTable.lookup "modules.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [String "\"<hello>\""]
Env.names env `shouldContain` [ "Bar" ]
other -> expectationFailure (show other)
it "handles break correctly" $ do
(_, (_, res)) <- evaluate "break.rb"
fmap snd <$> res `shouldBe` Right [Value.Integer (Number.Integer 3)]
(_, (heap, res)) <- evaluate ["break.rb"]
case ModuleTable.lookup "break.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
other -> expectationFailure (show other)
it "handles break correctly" $ do
(_, (_, res)) <- evaluate "next.rb"
fmap snd <$> res `shouldBe` Right [Value.Integer (Number.Integer 8)]
it "handles next correctly" $ do
(_, (heap, res)) <- evaluate ["next.rb"]
case ModuleTable.lookup "next.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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 snd <$> res `shouldBe` Right [Value.Integer (Number.Integer 579)]
(_, (heap, res)) <- evaluate ["call.rb"]
case ModuleTable.lookup "call.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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 snd <$> res `shouldBe` Right [Value.Integer (Number.Integer 123)]
(_, (heap, res)) <- evaluate ["early-return.rb"]
case ModuleTable.lookup "early-return.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)]
other -> expectationFailure (show other)
it "has prelude" $ do
(_, (_, res)) <- evaluate "preluded.rb"
fmap snd <$> res `shouldBe` Right [String "\"<foo>\""]
(_, (heap, res)) <- evaluate ["preluded.rb"]
case ModuleTable.lookup "preluded.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"<foo>\""]
other -> expectationFailure (show other)
it "evaluates __LINE__" $ do
(_, (_, res)) <- evaluate "line.rb"
fmap snd <$> res `shouldBe` Right [Value.Integer (Number.Integer 4)]
(_, (heap, res)) <- evaluate ["line.rb"]
case ModuleTable.lookup "line.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)]
other -> expectationFailure (show other)
it "resolves builtins used in the prelude" $ do
(traces, (_, res)) <- evaluate "puts.rb"
fmap snd <$> res `shouldBe` Right [Unit]
traces `shouldContain` [ "\"hello\"" ]
(traces, (heap, res)) <- evaluate ["puts.rb"]
case ModuleTable.lookup "puts.rb" <$> res of
Right (Just (Module _ (env, addr) :| [])) -> 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

41
test/Analysis/TypeScript/Spec.hs
View File

@ -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
(_, (state, Right [(env, _)])) <- evaluate "main1.ts"
Env.names env `shouldBe` [ "b", "z" ]
(_, (heap, res)) <- 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 fst <$> 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 snd <$> res `shouldBe` Right [Value.Float (Number.Decimal 123.0)]
(_, (heap, res)) <- 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

9
test/Control/Abstract/Evaluator/Spec.hs
View File

@ -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 . snd)
. runEnv lowerBound
. runReturn
@ -59,7 +59,6 @@ newtype SpecEff a = SpecEff
, Reader PackageInfo
, Fresh
, State (Heap Precise Latest Val)
, State (ModuleTable (Maybe (Environment Precise, Precise)))
, Lift IO
] a
}

1
test/Doctests.hs
View File

@ -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"
]

101
test/SpecHelpers.hs
View File

@ -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,76 +81,51 @@ 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 (Environment Precise, Precise)))
, Trace
]
[(Environment Precise, Precise)]
-> ( [String]
, ( EvaluatingState Precise Val
, Either
(SomeExc
(Data.Sum.Sum
'[ ValueError Precise TestEff
, AddressError Precise Val
, EvalError
, EnvironmentError Precise
, ResolutionError
, Unspecialized Val
, LoadError Precise Val
]))
[(Environment Precise, Value Precise TestEff)]))
type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise))
, Resumable (AddressError Precise Val)
, Resumable ResolutionError
, Resumable EvalError
, Resumable (EnvironmentError Precise)
, Resumable (Unspecialized Val)
, Resumable (LoadError Precise)
, Trace
, Fresh
, State (Heap Precise Latest Val)
, Lift IO
]
type TestEvaluatingErrors = '[ ValueError Precise (UtilEff Precise)
, AddressError Precise Val
, ResolutionError
, EvalError
, EnvironmentError Precise
, Unspecialized Val
, LoadError Precise
]
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (Environment Precise, Precise))))
-> IO
( [String]
, ( Heap Precise Latest Val
, Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
(ModuleTable (NonEmpty (Module (Environment Precise, Precise))))
)
)
testEvaluating
= run
= runM
. fmap (\ (heap, (traces, res)) -> (traces, (heap, res)))
. runState lowerBound
. runFresh 0
. runReturningTrace
. evaluating
. fmap reassociate
. runLoadError
. runUnspecialized
. runResolutionError
. runEnvironmentError
. runEvalError
. runResolutionError
. runAddressError
. runValueError
. (>>= traverse deref1)
. runTermEvaluator @_ @_ @Val
. runValueError @_ @Precise @(UtilEff Precise)
type Val = Value Precise TestEff
newtype TestEff a = TestEff
{ runTestEff :: Eff '[ Exc (LoopControl Precise)
, Exc (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 (Environment Precise, Precise)))
, Trace
] a
}
type Val = Value Precise (UtilEff Precise)
deref1 (env, ptr) = runAllocator $ do
val <- deref ptr
pure (env, val)
deNamespace :: Value Precise term -> Maybe (Name, [Name])
deNamespace (Namespace name scope) = Just (name, Env.names scope)