github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-18 12:21:57 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into import-graph-mk2

Browse Source
This commit is contained in:
Patrick Thomson 2018-06-26 13:49:24 -04:00
commit bbf814acc1
29 changed files with 606 additions and 468 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.Caching
, Analysis.Abstract.Collecting , Analysis.Abstract.Collecting
, Analysis.Abstract.Dead , Analysis.Abstract.Dead
, Analysis.Abstract.Evaluating
, Analysis.Abstract.Graph , Analysis.Abstract.Graph
, Analysis.Abstract.Tracing , Analysis.Abstract.Tracing
, Analysis.ConstructorName , Analysis.ConstructorName

31
src/Analysis/Abstract/Evaluating.hs
View File

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

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

@ -2,6 +2,7 @@
module Analysis.Abstract.Graph module Analysis.Abstract.Graph
( Graph(..) ( Graph(..)
, Vertex(..) , Vertex(..)
, moduleVertex
, style , style
, appendGraph , appendGraph
, variableDefinition , variableDefinition
@ -10,6 +11,7 @@ module Analysis.Abstract.Graph
, graphingTerms , graphingTerms
, graphingPackages , graphingPackages
, graphingModules , graphingModules
, graphingModuleInfo
, graphing , graphing
) where ) where
@ -59,6 +61,7 @@ graphingTerms recur term@(In _ syntax) = do
_ -> pure () _ -> pure ()
recur term recur term
-- | Add vertices to the graph for evaluated modules and the packages containing them.
graphingPackages :: ( Member (Reader PackageInfo) effects graphingPackages :: ( Member (Reader PackageInfo) effects
, Member (State (Graph Vertex)) effects , Member (State (Graph Vertex)) effects
) )
@ -66,20 +69,38 @@ graphingPackages :: ( Member (Reader PackageInfo) effects
-> SubtermAlgebra Module term (TermEvaluator term address value effects a) -> SubtermAlgebra Module term (TermEvaluator term address value effects a)
graphingPackages recur m = packageInclusion (moduleVertex (moduleInfo m)) *> recur m 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 graphingModules :: forall term address value effects a
. ( Member (Modules address value) effects . ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects , Member (Reader ModuleInfo) effects
, Member (State (Graph Vertex)) effects , Member (State (Graph Vertex)) effects
) )
=> SubtermAlgebra Module term (TermEvaluator term address value effects a) => SubtermAlgebra Module term (TermEvaluator term address value effects a)
-> 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 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 Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
_ -> send m >>= yield) _ -> send m >>= yield)
(recur m) (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. -- | Add an edge from the current package to the passed vertex.
packageInclusion :: ( Effectful m packageInclusion :: ( Effectful m
, Member (Reader PackageInfo) effects , Member (Reader PackageInfo) effects
@ -114,7 +135,7 @@ variableDefinition name = do
graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe) <$> TermEvaluator (lookupEnv name) graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe) <$> TermEvaluator (lookupEnv name)
appendGraph (vertex (Variable (formatName name)) `connect` graph) 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' . (<>) appendGraph = modify' . (<>)

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

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-} {-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
module Control.Abstract.Modules module Control.Abstract.Modules
( lookupModule ( lookupModule
, resolve , resolve
@ -23,115 +23,88 @@ import Data.Abstract.Environment
import Data.Abstract.Module import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.ModuleTable as ModuleTable
import Data.Language import Data.Language
import Data.Semigroup.Foldable (foldMap1)
import qualified Data.Set as Set
import Prologue 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. -- | 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 value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (address, Environment address))) lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
lookupModule = sendModules . Lookup lookupModule = sendModules . Lookup
-- | Resolve a list of module paths to a possible module table entry. -- | 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 :: Member (Modules address) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
resolve = sendModules . Resolve @address @value resolve = sendModules . Resolve
listModulesInDir :: forall address value effects . Member (Modules address value) effects => FilePath -> Evaluator address value effects [ModulePath] listModulesInDir :: Member (Modules address) effects => FilePath -> Evaluator address value effects [ModulePath]
listModulesInDir = sendModules . List @address @value listModulesInDir = sendModules . List
-- | Require/import another module by name and return its environment and value. -- | 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. -- 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) require path = lookupModule path >>= maybeM (load path)
-- | Load another module by name and return its environment and value. -- | Load another module by name and return its environment and value.
-- --
-- Always loads/evaluates. -- 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) load path = sendModules (Load path)
data Modules address value return where data Modules address return where
Load :: ModulePath -> Modules address value (Maybe (address, Environment address)) Load :: ModulePath -> Modules address (address, Environment address)
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (address, Environment address))) Lookup :: ModulePath -> Modules address (Maybe (address, Environment address))
Resolve :: [FilePath] -> Modules address value (Maybe ModulePath) Resolve :: [FilePath] -> Modules address (Maybe ModulePath)
List :: FilePath -> Modules address value [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 sendModules = send
runModules :: forall term address value effects a 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 value)) effects , Member (Resumable (LoadError address)) effects
, Member (State (ModuleTable (Maybe (address, Environment address)))) effects
, Member Trace effects
) )
=> (Module term -> Evaluator address value (Modules address value ': effects) (address, Environment address)) => Set ModulePath
-> Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Modules address ': effects) a
-> Evaluator address value (Reader (ModuleTable (NonEmpty (Module term))) ': effects) a -> Evaluator address value effects a
runModules evaluateModule = go runModules paths = interpret $ \case
where go :: forall a . Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Reader (ModuleTable (NonEmpty (Module term))) ': effects) a Load name -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (moduleNotFound name)
go = reinterpret (\ m -> case m of Lookup path -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path <$> askModuleTable
Load name -> askModuleTable @term >>= maybe (moduleNotFound name) (runMerging . foldMap (Merging . evalAndCache)) . ModuleTable.lookup name Resolve names -> pure (find (`Set.member` paths) names)
where List dir -> pure (filter ((dir ==) . takeDirectory) (toList paths))
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)
loadingModule path = isJust . ModuleTable.lookup path <$> getModuleTable askModuleTable :: Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module (address, Environment address))))
Lookup path -> ModuleTable.lookup path <$> get askModuleTable = 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
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 instance Semigroup (Merging address) where
Merging a <> Merging b = Merging (merge <$> a <*> b) Merging (_, env1) <> Merging (addr, env2) = Merging (addr, mergeEnvs env1 env2)
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)
-- | 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. -- | 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 data LoadError address resume where
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (address, Environment address)) ModuleNotFound :: ModulePath -> LoadError address (address, Environment address)
deriving instance Eq (LoadError address value resume) deriving instance Eq (LoadError address resume)
deriving instance Show (LoadError address value resume) deriving instance Show (LoadError address resume)
instance Show1 (LoadError address value) where instance Show1 (LoadError address) where
liftShowsPrec _ _ = showsPrec liftShowsPrec _ _ = showsPrec
instance Eq1 (LoadError address value) where instance Eq1 (LoadError address) where
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b 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 :: Member (Resumable (LoadError address)) effects => ModulePath -> Evaluator address value effects (address, Environment address)
moduleNotFound = throwResumable . ModuleNotFound @address @value 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 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 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 runLoadErrorWith = runResumableWith

103
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 Data.Abstract.Evaluatable
( module X ( module X
, Evaluatable(..) , Evaluatable(..)
, evaluatePackageWith , evaluate
, traceResolve , traceResolve
-- * Preludes -- * Preludes
, HasPrelude(..) , HasPrelude(..)
@ -17,7 +17,7 @@ module Data.Abstract.Evaluatable
, Cell , Cell
) where ) where
import Control.Abstract import Control.Abstract hiding (Load)
import Control.Abstract.Context as X import Control.Abstract.Context as X
import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith) import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith)
import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) 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.Module
import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Name as X import Data.Abstract.Name as X
import Data.Abstract.Package as Package
import Data.Abstract.Ref as X import Data.Abstract.Ref as X
import Data.Coerce
import Data.Language import Data.Language
import Data.Scientific (Scientific) import Data.Scientific (Scientific)
import Data.Semigroup.App import Data.Semigroup.App
@ -49,7 +49,7 @@ class Show1 constr => Evaluatable constr where
, Member (Allocator address value) effects , Member (Allocator address value) effects
, Member (Env address) effects , Member (Env address) effects
, Member (LoopControl address) effects , Member (LoopControl address) effects
, Member (Modules address value) effects , Member (Modules address) effects
, Member (Reader ModuleInfo) effects , Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects , Member (Reader PackageInfo) effects
, Member (Reader Span) 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 "")) eval expr = rvalBox =<< throwResumable (Unspecialized ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr ""))
-- | Evaluate a given package. evaluate :: ( AbstractValue address value inner
evaluatePackageWith :: forall proxy lang address term value inner inner' inner'' outer , Addressable address (Reader ModuleInfo ': effects)
. ( 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 , Declarations term
, Evaluatable (Base term) , Evaluatable (Base term)
, Foldable (Cell address) , Foldable (Cell address)
, FreeVariables term , FreeVariables term
, HasPrelude lang , HasPrelude lang
, Member Fresh outer , Member Fresh effects
, Member (Resumable (AddressError address value)) outer , Member (Modules address) effects
, Member (Resumable (EnvironmentError address)) outer , Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects
, Member (Resumable EvalError) outer , Member (Reader PackageInfo) effects
, Member (Resumable (LoadError address value)) outer , Member (Reader Span) effects
, Member (Resumable ResolutionError) outer , Member (Resumable (AddressError address value)) effects
, Member (Resumable (Unspecialized value)) outer , Member (Resumable (EnvironmentError address)) effects
, Member (State (Heap address (Cell address) value)) outer , Member (Resumable EvalError) effects
, Member (State (ModuleTable (Maybe (address, Environment address)))) outer , Member (Resumable ResolutionError) effects
, Member Trace outer , Member (Resumable (Unspecialized value)) effects
, Member (State (Heap address (Cell address) value)) effects
, Member Trace effects
, Recursive term , Recursive term
, Reducer value (Cell address value) , Reducer value (Cell address value)
, ValueRoots address value , ValueRoots address value
, inner ~ (LoopControl address ': Return address ': Env address ': Allocator address value ': inner') , inner ~ (LoopControl address ': Return address ': Env address ': Allocator address value ': Reader ModuleInfo ': effects)
, inner' ~ (Reader ModuleInfo ': inner'')
, inner'' ~ (Modules address value ': Reader Span ': Reader PackageInfo ': outer)
) )
=> proxy lang => proxy lang
-> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address)) -> (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))) -> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)))
-> Package term -> [Module term]
-> TermEvaluator term address value outer [(address, Environment address)] -> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (address, Environment address))))
evaluatePackageWith lang analyzeModule analyzeTerm package evaluate lang analyzeModule analyzeTerm modules = do
= runReader (packageInfo package) (_, preludeEnv) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack $ do
. 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)))
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 defineBuiltins
definePrelude lang definePrelude lang
box unit box unit
f preludeEnv 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
. runAllocator
. runEnv preludeEnv
. runReturn
. runLoopControl
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () 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 Prologue
import System.FilePath.Posix 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) deriving (Eq, Foldable, Functor, Ord, Traversable)
instance Show (Module term) where instance Show body => Show (Module body) where
showsPrec _ Module{..} = shows moduleInfo showsPrec d Module{..} = showsBinaryWith showsPrec showsPrec "Module" d (modulePath moduleInfo) moduleBody
-- | Construct a 'Module' for a 'Blob' and @term@, relative to some root 'FilePath'. -- | 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 type ModulePath = FilePath
newtype ModuleInfo = ModuleInfo { modulePath :: ModulePath } 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 :: SrcLoc -> ModuleInfo
moduleInfoFromSrcLoc = ModuleInfo . srcLocModule moduleInfoFromSrcLoc = ModuleInfo . srcLocModule

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

@ -5,6 +5,7 @@ module Data.Abstract.ModuleTable
, singleton , singleton
, lookup , lookup
, member , member
, modulePaths
, modulePathsInDir , modulePathsInDir
, insert , insert
, keys , keys
@ -26,6 +27,9 @@ newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a }
singleton :: ModulePath -> a -> ModuleTable a singleton :: ModulePath -> a -> ModuleTable a
singleton name = ModuleTable . Map.singleton name singleton name = ModuleTable . Map.singleton name
modulePaths :: ModuleTable a -> Set ModulePath
modulePaths = Map.keysSet . unModuleTable
modulePathsInDir :: FilePath -> ModuleTable a -> [ModulePath] modulePathsInDir :: FilePath -> ModuleTable a -> [ModulePath]
modulePathsInDir k = filter (\e -> k == takeDirectory e) . Map.keys . unModuleTable 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 module Data.Abstract.Package where
import Data.Abstract.Module import Data.Abstract.Module
@ -12,30 +11,16 @@ type PackageName = Name
-- | Metadata for a package (name and version). -- | Metadata for a package (name and version).
data PackageInfo = PackageInfo data PackageInfo = PackageInfo
{ packageName :: PackageName { packageName :: PackageName
, packageVersion :: Maybe Version
, packageResolutions :: Map.Map FilePath FilePath , packageResolutions :: Map.Map FilePath FilePath
} }
deriving (Eq, Ord, Show) 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. -- | 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 data Package term = Package
{ packageInfo :: PackageInfo { packageInfo :: PackageInfo
, packageBody :: PackageBody term , packageModules :: ModuleTable (NonEmpty (Module term))
} }
deriving (Eq, Functor, Ord, Show) deriving (Eq, Functor, Ord, Show)
fromModules :: PackageName -> Maybe Version -> Int -> [Module term] -> Map.Map FilePath FilePath -> Package term fromModules :: PackageName -> [Module term] -> Map.Map FilePath FilePath -> Package term
fromModules name version entryPoints modules resolutions = fromModules name modules resolutions = Package (PackageInfo name resolutions) (ModuleTable.fromModules modules)
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

75
src/Data/Graph.hs
View File

@ -1,32 +1,93 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
module Data.Graph module Data.Graph
( Graph(..) ( Graph(..)
, Class.overlay , overlay
, Class.connect , connect
, Class.vertex , vertex
, Lower(..) , Lower(..)
, simplify , simplify
, topologicalSort
) where ) where
import qualified Algebra.Graph as G 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 qualified Algebra.Graph.Class as Class
import Control.Monad.Effect
import Control.Monad.Effect.State
import Data.Aeson import Data.Aeson
import qualified Data.Set as Set
import Prologue import Prologue
-- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances. -- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances.
newtype Graph vertex = Graph (G.Graph vertex) newtype Graph vertex = Graph { unGraph :: G.Graph vertex }
deriving (Eq, Foldable, Functor, Class.Graph, Show, Class.ToGraph, Traversable) deriving (Alternative, Applicative, Eq, Foldable, Functor, Class.Graph, Monad, Show, Class.ToGraph, Traversable)
simplify :: Ord vertex => Graph vertex -> Graph vertex simplify :: Ord vertex => Graph vertex -> Graph vertex
simplify (Graph graph) = Graph (G.simplify graph) 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 instance Lower (Graph vertex) where
lowerBound = Class.empty lowerBound = Class.empty
instance Semigroup (Graph vertex) where instance Semigroup (Graph vertex) where
(<>) = Class.overlay (<>) = overlay
instance Monoid (Graph vertex) where instance Monoid (Graph vertex) where
mempty = Class.empty mempty = Class.empty

2
src/Data/Project.hs
View File

@ -38,7 +38,6 @@ data ProjectF (blobs :: * -> *) (paths :: * -> *) path = Project
{ projectRootDir :: path { projectRootDir :: path
, projectBlobs :: blobs Blob , projectBlobs :: blobs Blob
, projectLanguage :: Language , projectLanguage :: Language
, projectEntryPaths :: paths path
, projectExcludeDirs :: paths path , projectExcludeDirs :: paths path
} deriving (Functor, Generic) } deriving (Functor, Generic)
@ -63,7 +62,6 @@ fromPB Project {..} = Project
{ projectRootDir = T.unpack projectRootDir { projectRootDir = T.unpack projectRootDir
, projectBlobs = toList projectBlobs , projectBlobs = toList projectBlobs
, projectLanguage = projectLanguage , projectLanguage = projectLanguage
, projectEntryPaths = T.unpack <$> toList projectEntryPaths
, projectExcludeDirs = T.unpack <$> toList projectExcludeDirs , projectExcludeDirs = T.unpack <$> toList projectExcludeDirs
} }

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 :: ImportPath -> Name
defaultAlias = name . T.pack . takeFileName . unPath defaultAlias = name . T.pack . takeFileName . unPath
resolveGoImport :: ( Member (Modules address value) effects resolveGoImport :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects , Member (Reader ModuleInfo) effects
, Member (Reader Package.PackageInfo) effects , Member (Reader Package.PackageInfo) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
@ -66,7 +66,7 @@ instance Evaluatable Import where
paths <- resolveGoImport importPath paths <- resolveGoImport importPath
for_ paths $ \path -> do for_ paths $ \path -> do
traceResolve (unPath importPath) path traceResolve (unPath importPath) path
importedEnv <- maybe lowerBound snd <$> require path importedEnv <- snd <$> require path
bindAll importedEnv bindAll importedEnv
rvalBox unit rvalBox unit
@ -88,7 +88,7 @@ instance Evaluatable QualifiedImport where
void . letrec' alias $ \addr -> do void . letrec' alias $ \addr -> do
for_ paths $ \p -> do for_ paths $ \p -> do
traceResolve (unPath importPath) p traceResolve (unPath importPath) p
importedEnv <- maybe lowerBound snd <$> require p importedEnv <- snd <$> require p
bindAll importedEnv bindAll importedEnv
makeNamespace alias addr Nothing makeNamespace alias addr Nothing
rvalBox unit 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 -- file, the complete contents of the included file are treated as though it
-- were defined inside that function. -- were defined inside that function.
resolvePHPName :: ( Member (Modules address value) effects resolvePHPName :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
) )
=> T.Text => T.Text
@ -49,20 +49,19 @@ resolvePHPName n = do
include :: ( AbstractValue address value effects include :: ( AbstractValue address value effects
, Member (Allocator address value) effects , Member (Allocator address value) effects
, Member (Env address) effects , Member (Env address) effects
, Member (Modules address value) effects , Member (Modules address) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
, Member (Resumable (EnvironmentError address)) effects , Member (Resumable (EnvironmentError address)) effects
, Member Trace effects , Member Trace effects
) )
=> Subterm term (Evaluator address value effects (ValueRef address)) => 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) -> Evaluator address value effects (ValueRef address)
include pathTerm f = do include pathTerm f = do
name <- subtermValue pathTerm >>= asString name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name path <- resolvePHPName name
traceResolve name path traceResolve name path
unitPtr <- box unit -- TODO don't always allocate, use maybeM (v, importedEnv) <- f path
(v, importedEnv) <- fromMaybe (unitPtr, lowerBound) <$> f path
bindAll importedEnv bindAll importedEnv
pure (Rval v) 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 -- Subsequent imports of `parent.two` or `parent.three` will execute
-- `parent/two/__init__.py` and -- `parent/two/__init__.py` and
-- `parent/three/__init__.py` respectively. -- `parent/three/__init__.py` respectively.
resolvePythonModules :: ( Member (Modules address value) effects resolvePythonModules :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects , Member (Reader ModuleInfo) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
, Member Trace effects , Member Trace effects
@ -113,7 +113,7 @@ instance Evaluatable Import where
-- Last module path is the one we want to import -- Last module path is the one we want to import
let path = NonEmpty.last modulePaths let path = NonEmpty.last modulePaths
importedEnv <- maybe lowerBound snd <$> require path importedEnv <- snd <$> require path
bindAll (select importedEnv) bindAll (select importedEnv)
rvalBox unit rvalBox unit
where where
@ -126,11 +126,11 @@ instance Evaluatable Import where
evalQualifiedImport :: ( AbstractValue address value effects evalQualifiedImport :: ( AbstractValue address value effects
, Member (Allocator address value) effects , Member (Allocator address value) effects
, Member (Env address) effects , Member (Env address) effects
, Member (Modules address value) effects , Member (Modules address) effects
) )
=> Name -> ModulePath -> Evaluator address value effects value => Name -> ModulePath -> Evaluator address value effects value
evalQualifiedImport name path = letrec' name $ \addr -> do evalQualifiedImport name path = letrec' name $ \addr -> do
importedEnv <- maybe lowerBound snd <$> require path importedEnv <- snd <$> require path
bindAll importedEnv bindAll importedEnv
unit <$ makeNamespace name addr Nothing unit <$ makeNamespace name addr Nothing
@ -174,7 +174,7 @@ instance Evaluatable QualifiedAliasedImport where
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
rvalBox =<< letrec' alias (\addr -> do rvalBox =<< letrec' alias (\addr -> do
let path = NonEmpty.last modulePaths let path = NonEmpty.last modulePaths
importedEnv <- maybe lowerBound snd <$> require path importedEnv <- snd <$> require path
bindAll importedEnv bindAll importedEnv
unit <$ makeNamespace alias addr Nothing) 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 -- TODO: Fully sort out ruby require/load mechanics
-- --
-- require "json" -- require "json"
resolveRubyName :: ( Member (Modules address value) effects resolveRubyName :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
) )
=> Text => Text
@ -28,7 +28,7 @@ resolveRubyName name = do
maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath
-- load "/root/src/file.rb" -- load "/root/src/file.rb"
resolveRubyPath :: ( Member (Modules address value) effects resolveRubyPath :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
) )
=> Text => 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 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 doRequire :: ( AbstractValue address value effects
, Member (Modules address value) effects , Member (Modules address) effects
) )
=> M.ModulePath => M.ModulePath
-> Evaluator address value effects (value, Environment address) -> Evaluator address value effects (value, Environment address)
doRequire path = do doRequire path = do
result <- join <$> lookupModule path result <- lookupModule path
case result of case result of
Nothing -> (,) (boolean True) . maybe lowerBound snd <$> load path Nothing -> (,) (boolean True) . snd <$> load path
Just (_, env) -> pure (boolean False, env) Just (_, env) -> pure (boolean False, env)
@ -102,7 +102,7 @@ instance Evaluatable Load where
doLoad :: ( AbstractValue address value effects doLoad :: ( AbstractValue address value effects
, Member (Env address) effects , Member (Env address) effects
, Member (Modules address value) effects , Member (Modules address) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
, Member Trace effects , Member Trace effects
) )
@ -112,7 +112,7 @@ doLoad :: ( AbstractValue address value effects
doLoad path shouldWrap = do doLoad path shouldWrap = do
path' <- resolveRubyPath path path' <- resolveRubyPath path
traceResolve path path' traceResolve path path'
importedEnv <- maybe lowerBound snd <$> load path' importedEnv <- snd <$> load path'
unless shouldWrap $ bindAll importedEnv 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 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 -- NB: TypeScript has a couple of different strategies, but the main one (and the
-- only one we support) mimics Node.js. -- 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 M.ModuleInfo) effects
, Member (Reader PackageInfo) effects , Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
@ -54,7 +54,7 @@ resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativ
-- /root/src/moduleB.ts -- /root/src/moduleB.ts
-- /root/src/moduleB/package.json (if it specifies a "types" property) -- /root/src/moduleB/package.json (if it specifies a "types" property)
-- /root/src/moduleB/index.ts -- /root/src/moduleB/index.ts
resolveRelativePath :: ( Member (Modules address value) effects resolveRelativePath :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects , Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects , Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
@ -82,7 +82,7 @@ resolveRelativePath relImportPath exts = do
-- --
-- /root/node_modules/moduleB.ts, etc -- /root/node_modules/moduleB.ts, etc
-- /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 M.ModuleInfo) effects
, Member (Reader PackageInfo) effects , Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects , Member (Resumable ResolutionError) effects
@ -107,7 +107,7 @@ resolveNonRelativePath name exts = do
notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript
-- | Resolve a module name to a ModulePath. -- | Resolve a module name to a ModulePath.
resolveModule :: ( Member (Modules address value) effects resolveModule :: ( Member (Modules address) effects
, Member (Reader PackageInfo) effects , Member (Reader PackageInfo) effects
, Member Trace effects , Member Trace effects
) )
@ -133,13 +133,13 @@ javascriptExtensions = ["js"]
evalRequire :: ( AbstractValue address value effects evalRequire :: ( AbstractValue address value effects
, Member (Allocator address value) effects , Member (Allocator address value) effects
, Member (Env address) effects , Member (Env address) effects
, Member (Modules address value) effects , Member (Modules address) effects
) )
=> M.ModulePath => M.ModulePath
-> Name -> Name
-> Evaluator address value effects value -> Evaluator address value effects value
evalRequire modulePath alias = letrec' alias $ \addr -> do evalRequire modulePath alias = letrec' alias $ \addr -> do
importedEnv <- maybe lowerBound snd <$> require modulePath importedEnv <- snd <$> require modulePath
bindAll importedEnv bindAll importedEnv
unit <$ makeNamespace alias addr Nothing unit <$ makeNamespace alias addr Nothing
@ -154,7 +154,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Import where instance Evaluatable Import where
eval (Import symbols importPath) = do eval (Import symbols importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
importedEnv <- maybe lowerBound snd <$> require modulePath importedEnv <- snd <$> require modulePath
bindAll (renamed importedEnv) bindAll (renamed importedEnv)
rvalBox unit rvalBox unit
where where
@ -230,7 +230,7 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedExportFrom where instance Evaluatable QualifiedExportFrom where
eval (QualifiedExportFrom importPath exportSymbols) = do eval (QualifiedExportFrom importPath exportSymbols) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions 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. -- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
for_ exportSymbols $ \(name, alias) -> do for_ exportSymbols $ \(name, alias) -> do
let address = Env.lookup name importedEnv let address = Env.lookup name importedEnv

2
src/Semantic/CLI.hs
View File

@ -82,7 +82,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format 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 graphArgumentsParser = do
graphType <- flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") graphType <- flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)")
<|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") <|> 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
defaultOptions = Options (Just Warning) Nothing False defaultOptions = Options (Just Warning) Nothing False
debugOptions :: Options
debugOptions = Options (Just Debug) Nothing False
defaultConfig :: Options -> IO Config defaultConfig :: Options -> IO Config
defaultConfig options@Options{..} = do defaultConfig options@Options{..} = do
pid <- getProcessID pid <- getProcessID

125
src/Semantic/Graph.hs
View File

@ -1,10 +1,12 @@
{-# LANGUAGE GADTs, TypeOperators #-} {-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}
module Semantic.Graph module Semantic.Graph
( runGraph ( runGraph
, runImportGraph
, GraphType(..) , GraphType(..)
, Graph , Graph
, Vertex , Vertex
, GraphEff(..) , GraphEff(..)
, ImportGraphEff(..)
, style , style
, parsePackage , parsePackage
, withTermSpans , withTermSpans
@ -17,15 +19,13 @@ module Semantic.Graph
, resumingEnvironmentError , resumingEnvironmentError
) where ) where
import Prelude hiding (readFile) import Analysis.Abstract.Graph as Graph
import Analysis.Abstract.Evaluating
import Analysis.Abstract.Graph
import Control.Abstract import Control.Abstract
import Control.Monad.Effect (reinterpret) import Control.Monad.Effect (reinterpret)
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Evaluatable import Data.Abstract.Evaluatable
import Data.Abstract.Module import Data.Abstract.Module
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package as Package import Data.Abstract.Package as Package
import Data.Abstract.Value (Value, ValueError (..), runValueErrorWith) import Data.Abstract.Value (Value, ValueError (..), runValueErrorWith)
import Data.Graph import Data.Graph
@ -39,25 +39,28 @@ import Semantic.Task as Task
data GraphType = ImportGraph | CallGraph 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) runGraph :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Task effs, Member Trace effs)
=> GraphType => GraphType
-> Bool -> Bool
-> Project -> Project
-> Eff effs (Graph Vertex) -> Eff effs (Graph Vertex)
runGraph graphType includePackages project runGraph ImportGraph _ project
| SomeAnalysisParser parser lang <- someAnalysisParser | SomeAnalysisParser parser lang <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do
(Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
package <- parsePackage parser project package <- parsePackage parser project
let analyzeTerm = withTermSpans . case graphType of fmap (Graph.moduleVertex . moduleInfo) <$> runImportGraph lang package
ImportGraph -> id runGraph CallGraph includePackages project
CallGraph -> graphingTerms | 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 analyzeModule = (if includePackages then graphingPackages else id) . graphingModules
analyze runGraphAnalysis (evaluatePackageWith lang analyzeModule analyzeTerm package) >>= extractGraph extractGraph (((_, graph), _), _) = simplify graph
where extractGraph result = case result of
(((_, graph), _), _) -> pure (simplify graph)
runGraphAnalysis runGraphAnalysis
= run = run
. evaluating . runState lowerBound
. runFresh 0
. runIgnoringTrace . runIgnoringTrace
. resumingLoadError . resumingLoadError
. resumingUnspecialized . resumingUnspecialized
@ -68,6 +71,12 @@ runGraph graphType includePackages project
. resumingValueError . resumingValueError
. runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _)) . runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (GraphEff _))
. graphing . 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. -- | 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 newtype GraphEff address a = GraphEff
@ -76,7 +85,9 @@ newtype GraphEff address a = GraphEff
, Env address , Env address
, Allocator address (Value address (GraphEff address)) , Allocator address (Value address (GraphEff address))
, Reader ModuleInfo , 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 Span
, Reader PackageInfo , Reader PackageInfo
, State (Graph Vertex) , State (Graph Vertex)
@ -86,14 +97,80 @@ newtype GraphEff address a = GraphEff
, Resumable EvalError , Resumable EvalError
, Resumable (EnvironmentError address) , Resumable (EnvironmentError address)
, Resumable (Unspecialized (Value address (GraphEff address))) , Resumable (Unspecialized (Value address (GraphEff address)))
, Resumable (LoadError address (Value address (GraphEff address))) , Resumable (LoadError address)
, Trace , Trace
, Fresh , Fresh
, State (Heap address Latest (Value address (GraphEff address))) , State (Heap address Latest (Value address (GraphEff address)))
, State (ModuleTable (Maybe (address, Environment address)))
] a ] 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'. -- | Parse a list of files into a 'Package'.
parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Trace effs) parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Trace effs)
=> Parser term -- ^ A parser. => Parser term -- ^ A parser.
@ -102,15 +179,15 @@ parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, M
parsePackage parser project@Project{..} = do parsePackage parser project@Project{..} = do
p <- parseModules parser p <- parseModules parser
resMap <- Task.resolutionMap project resMap <- Task.resolutionMap project
let pkg = Package.fromModules n Nothing (length projectEntryPaths) p resMap let pkg = Package.fromModules n p resMap
pkg <$ trace ("project: " <> show pkg) pkg <$ trace ("project: " <> show (() <$ pkg))
where where
n = name (projectName project) n = name (projectName project)
-- | Parse all files in a project into 'Module's. -- | Parse all files in a project into 'Module's.
parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Eff effs [Module term] parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Project -> Eff effs [Module term]
parseModules parser = distributeFor (projectEntryPoints project <> projectFiles project) (WrapTask . parseModule project parser) parseModules parser Project{..} = distributeFor projectFiles (WrapTask . parseModule parser (Just projectRootDir))
-- | Parse a file into a 'Module'. -- | Parse a file into a 'Module'.
parseModule :: (Member (Exc SomeException) effs, Member Task effs) => Project -> Parser term -> File -> Eff effs (Module term) 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 NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve]) GoImportError pathToResolve -> pure [pathToResolve])
resumingLoadError :: Member Trace effects => Evaluator address value (Resumable (LoadError address value) ': effects) a -> Evaluator address value effects a 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) $> Nothing) 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 :: 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 resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of

13
src/Semantic/IO.hs
View File

@ -101,15 +101,12 @@ readBlobFromPath file = do
readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
readProjectFromPaths maybeRoot path lang excludeDirs = do readProjectFromPaths maybeRoot path lang excludeDirs = do
isDir <- isDirectory path isDir <- isDirectory path
let (filterFun, entryPoints, rootDir) = if isDir let rootDir = if isDir
then (id, [], fromMaybe path maybeRoot) then fromMaybe path maybeRoot
else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot) else fromMaybe (takeDirectory path) maybeRoot
paths <- liftIO $ findFilesInDir rootDir exts excludeDirs
paths <- liftIO $ filterFun <$> findFilesInDir rootDir exts excludeDirs pure $ Project rootDir (toFile <$> paths) lang excludeDirs
let providedFiles = entryPoints <> (toFile <$> paths)
blobs <- traverse readBlobFromPath providedFiles
pure (Project rootDir blobs lang (filePath <$> entryPoints) excludeDirs)
where where
toFile path = File path lang toFile path = File path lang
exts = extensionsForLanguage lang exts = extensionsForLanguage lang

1
src/Semantic/Task.hs
View File

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

64
src/Semantic/Util.hs
View File

@ -4,17 +4,21 @@ module Semantic.Util where
import Analysis.Abstract.Caching import Analysis.Abstract.Caching
import Analysis.Abstract.Collecting import Analysis.Abstract.Collecting
import Analysis.Abstract.Evaluating
import Control.Abstract import Control.Abstract
import Control.Monad.Effect.Trace (runPrintingTrace) import Control.Monad.Effect.Trace (runPrintingTrace)
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Evaluatable import Data.Abstract.Evaluatable
import Data.Abstract.Value 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.Abstract.Type
import Data.Blob import Data.Blob
import Data.Project
import Data.Functor.Foldable import Data.Functor.Foldable
import Data.Graph (topologicalSort)
import qualified Data.Language as Language import qualified Data.Language as Language
import Data.List (uncons)
import Data.Project
import Data.Sum (weaken) import Data.Sum (weaken)
import Data.Term import Data.Term
import Language.Haskell.HsColour import Language.Haskell.HsColour
@ -24,12 +28,14 @@ import Prologue hiding (weaken)
import Semantic.Graph import Semantic.Graph
import Semantic.IO as IO import Semantic.IO as IO
import Semantic.Task import Semantic.Task
import System.FilePath.Posix (takeDirectory)
import Text.Show (showListWith) import Text.Show (showListWith)
import Text.Show.Pretty (ppShow) import Text.Show.Pretty (ppShow)
justEvaluating justEvaluating
= runM = runM
. evaluating . runState lowerBound
. runFresh 0
. runPrintingTrace . runPrintingTrace
. fmap reassociate . fmap reassociate
. runLoadError . runLoadError
@ -38,7 +44,6 @@ justEvaluating
. runEnvironmentError . runEnvironmentError
. runEvalError . runEvalError
. runAddressError . runAddressError
. runTermEvaluator @_ @Precise @(Value Precise (UtilEff _))
. runValueError . runValueError
newtype UtilEff address a = UtilEff newtype UtilEff address a = UtilEff
@ -47,7 +52,8 @@ newtype UtilEff address a = UtilEff
, Env address , Env address
, Allocator address (Value address (UtilEff address)) , Allocator address (Value address (UtilEff address))
, Reader ModuleInfo , Reader ModuleInfo
, Modules address (Value address (UtilEff address)) , Modules address
, State (ModuleTable (NonEmpty (Module (address, Environment address))))
, Reader Span , Reader Span
, Reader PackageInfo , Reader PackageInfo
, Resumable (ValueError address (UtilEff address)) , Resumable (ValueError address (UtilEff address))
@ -56,18 +62,18 @@ newtype UtilEff address a = UtilEff
, Resumable (EnvironmentError address) , Resumable (EnvironmentError address)
, Resumable ResolutionError , Resumable ResolutionError
, Resumable (Unspecialized (Value address (UtilEff address))) , Resumable (Unspecialized (Value address (UtilEff address)))
, Resumable (LoadError address (Value address (UtilEff address))) , Resumable (LoadError address)
, Trace , Trace
, Fresh , Fresh
, State (Heap address Latest (Value address (UtilEff address))) , State (Heap address Latest (Value address (UtilEff address)))
, State (ModuleTable (Maybe (address, Environment address)))
, IO , IO
] a ] a
} }
checking checking
= runM @_ @IO = runM @_ @IO
. evaluating . runState (lowerBound @(Heap Monovariant All Type))
. runFresh 0
. runPrintingTrace . runPrintingTrace
. runTermEvaluator @_ @Monovariant @Type . runTermEvaluator @_ @Monovariant @Type
. caching @[] . caching @[]
@ -81,18 +87,40 @@ checking
. runAddressError . runAddressError
. runTypeError . runTypeError
evalGoProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path evalGoProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go
evalRubyProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path evalRubyProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby
evalPHPProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path evalPHPProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP
evalPythonProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path evalPythonProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python
evalJavaScriptProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser Language.JavaScript path evalJavaScriptProject = justEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.JavaScript) typescriptParser Language.JavaScript
evalTypeScriptProject path = justEvaluating =<< evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path 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. -- Evaluate a project consisting of the listed paths.
evaluateProject proxy parser lang path = evaluatePackageWith proxy id withTermSpans . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser) evaluateProject proxy parser lang paths = runTaskWithOptions debugOptions $ do
evaluateProjectWithCaching proxy parser lang path = evaluatePackageWith proxy convergingModules (withTermSpans . cachingTerms) . fmap quieterm <$> runTask (readProject Nothing path lang [] >>= parsePackage parser) 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 parseFile :: Parser term -> FilePath -> IO term

23
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.Environment as Env
import Data.Abstract.Evaluatable (EvalError(..)) import Data.Abstract.Evaluatable (EvalError(..))
import qualified Data.Abstract.ModuleTable as ModuleTable
import qualified Data.Language as Language import qualified Data.Language as Language
import qualified Language.Go.Assignment as Go import qualified Language.Go.Assignment as Go
import SpecHelpers import SpecHelpers
@ -9,20 +10,24 @@ import SpecHelpers
spec :: Spec spec :: Spec
spec = parallel $ do spec = parallel $ do
describe "evaluates Go" $ do describe "Go" $ do
it "imports and wildcard imports" $ do it "imports and wildcard imports" $ do
((Right [(_, env)], state), _) <- evaluate "main.go" ((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" ] Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ]
(derefQName heap ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"])
(derefQName (heap state) ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"]) other -> expectationFailure (show other)
it "imports with aliases (and side effects only)" $ do it "imports with aliases (and side effects only)" $ do
((Right [(_, env)], state), _) <- evaluate "main1.go" ((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" ] Env.names env `shouldBe` [ "f", "main" ]
(derefQName heap ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"])
(derefQName (heap state) ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"]) other -> expectationFailure (show other)
where where
fixtures = "test/fixtures/go/analysis/" fixtures = "test/fixtures/go/analysis/"
evaluate entry = evalGoProject (fixtures <> entry) evaluate = evalGoProject . map (fixtures <>)
evalGoProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go path evalGoProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Go) goParser Language.Go

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

@ -4,6 +4,7 @@ import Control.Abstract
import Data.Abstract.Environment as Env import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable (EvalError(..)) import Data.Abstract.Evaluatable (EvalError(..))
import qualified Data.Language as Language import qualified Data.Language as Language
import qualified Data.Abstract.ModuleTable as ModuleTable
import qualified Language.PHP.Assignment as PHP import qualified Language.PHP.Assignment as PHP
import SpecHelpers import SpecHelpers
@ -12,24 +13,33 @@ spec :: Spec
spec = parallel $ do spec = parallel $ do
describe "PHP" $ do describe "PHP" $ do
it "evaluates include and require" $ do it "evaluates include and require" $ do
((Right [(res, env)], state), _) <- evaluate "main.php" ((res, heap), _) <- evaluate ["main.php", "foo.php", "bar.php"]
res `shouldBe` unit 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" ] Env.names env `shouldBe` [ "bar", "foo" ]
other -> expectationFailure (show other)
it "evaluates include_once and require_once" $ do it "evaluates include_once and require_once" $ do
((Right [(res, env)], state), _) <- evaluate "main_once.php" ((res, heap), _) <- evaluate ["main_once.php", "foo.php", "bar.php"]
res `shouldBe` unit 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" ] Env.names env `shouldBe` [ "bar", "foo" ]
other -> expectationFailure (show other)
it "evaluates namespaces" $ do it "evaluates namespaces" $ do
((Right [(_, env)], state), _) <- evaluate "namespaces.php" ((res, heap), _) <- evaluate ["namespaces.php"]
case ModuleTable.lookup "namespaces.php" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
Env.names env `shouldBe` [ "Foo", "NS1" ] Env.names env `shouldBe` [ "Foo", "NS1" ]
(derefQName (heap state) ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) (derefQName heap ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
(derefQName (heap state) ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) (derefQName heap ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"])
(derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) (derefQName heap ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"])
other -> expectationFailure (show other)
where where
fixtures = "test/fixtures/php/analysis/" fixtures = "test/fixtures/php/analysis/"
evaluate entry = evalPHPProject (fixtures <> entry) evaluate = evalPHPProject . map (fixtures <>)
evalPHPProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP path evalPHPProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.PHP) phpParser Language.PHP

50
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.Environment as Env
import Data.Abstract.Evaluatable (EvalError(..)) import Data.Abstract.Evaluatable (EvalError(..))
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Value import Data.Abstract.Value
import Data.Map
import qualified Language.Python.Assignment as Python import qualified Language.Python.Assignment as Python
import qualified Data.Language as Language import qualified Data.Language as Language
@ -12,38 +12,52 @@ import SpecHelpers
spec :: Spec spec :: Spec
spec = parallel $ do spec = parallel $ do
describe "evaluates Python" $ do describe "Python" $ do
it "imports" $ do it "imports" $ do
((Right [(_, env)], state), _) <- evaluate "main.py" ((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" ] Env.names env `shouldContain` [ "a", "b" ]
(derefQName (heap state) ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"]) (derefQName heap ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"])
(derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"]) (derefQName heap ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"])
(derefQName (heap state) ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"]) (derefQName heap ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"])
other -> expectationFailure (show other)
it "imports with aliases" $ do it "imports with aliases" $ do
((Right [(_, env)], _), _) <- evaluate "main1.py" ((res, _), _) <- evaluate ["main1.py", "a.py", "b/__init__.py", "b/c.py"]
Env.names env `shouldContain` [ "b", "e" ] 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 it "imports using 'from' syntax" $ do
((Right [(_, env)], _), _) <- evaluate "main2.py" ((res, _), _) <- evaluate ["main2.py", "a.py", "b/__init__.py", "b/c.py"]
Env.names env `shouldContain` [ "bar", "foo" ] 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 it "imports with relative syntax" $ do
((Right [(_, env)], state), _) <- evaluate "main3.py" ((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" ] Env.names env `shouldContain` [ "utils" ]
(derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) (derefQName heap ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
other -> expectationFailure (show other)
it "subclasses" $ do it "subclasses" $ do
((res, _), _) <- evaluate "subclass.py" ((res, heap), _) <- evaluate ["subclass.py"]
fmap fst <$> res `shouldBe` Right [String "\"bar\""] 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 it "handles multiple inheritance left-to-right" $ do
((res, _), _) <- evaluate "multiple_inheritance.py" ((res, heap), _) <- evaluate ["multiple_inheritance.py"]
fmap fst <$> res `shouldBe` Right [String "\"foo!\""] 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 where
ns n = Just . Latest . Last . Just . Namespace n ns n = Just . Latest . Last . Just . Namespace n
fixtures = "test/fixtures/python/analysis/" fixtures = "test/fixtures/python/analysis/"
evaluate entry = evalPythonProject (fixtures <> entry) evaluate = evalPythonProject . map (fixtures <>)
evalPythonProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python path evalPythonProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Python) pythonParser Language.Python

83
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.Environment as Env
import Data.Abstract.Evaluatable import Data.Abstract.Evaluatable
import Data.Abstract.Value as Value import Data.Abstract.Value as Value
import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Number as Number import Data.Abstract.Number as Number
import Data.AST import Data.AST
import Control.Monad.Effect (SomeExc(..)) import Control.Monad.Effect (SomeExc(..))
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import Data.Map
import Data.Map.Monoidal as Map
import Data.Sum import Data.Sum
import qualified Language.Ruby.Assignment as Ruby import qualified Language.Ruby.Assignment as Ruby
import qualified Data.Language as Language import qualified Data.Language as Language
@ -20,61 +19,89 @@ spec :: Spec
spec = parallel $ do spec = parallel $ do
describe "Ruby" $ do describe "Ruby" $ do
it "evaluates require_relative" $ do it "evaluates require_relative" $ do
((Right [(res, env)], state), _) <- evaluate "main.rb" ((res, heap), _) <- evaluate ["main.rb", "foo.rb"]
res `shouldBe` Value.Integer (Number.Integer 1) 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" ] Env.names env `shouldContain` [ "foo" ]
other -> expectationFailure (show other)
it "evaluates load" $ do it "evaluates load" $ do
((Right [(_, env)], _), _) <- evaluate "load.rb" ((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" ] Env.names env `shouldContain` [ "foo" ]
other -> expectationFailure (show other)
it "evaluates load with wrapper" $ do 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"))) res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
it "evaluates subclass" $ do it "evaluates subclass" $ do
((Right [(res, env)], state), _) <- evaluate "subclass.rb" ((res, heap), _) <- evaluate ["subclass.rb"]
res `shouldBe` String "\"<bar>\"" case ModuleTable.lookup "subclass.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [String "\"<bar>\""]
Env.names env `shouldContain` [ "Bar", "Foo" ] 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 it "evaluates modules" $ do
((Right [(res, env)], state), _) <- evaluate "modules.rb" ((res, heap), _) <- evaluate ["modules.rb"]
res `shouldBe` String "\"<hello>\"" case ModuleTable.lookup "modules.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [String "\"<hello>\""]
Env.names env `shouldContain` [ "Bar" ] Env.names env `shouldContain` [ "Bar" ]
other -> expectationFailure (show other)
it "handles break correctly" $ do it "handles break correctly" $ do
((res, _), _) <- evaluate "break.rb" ((res, heap), _) <- evaluate ["break.rb"]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 3)] 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 it "handles next correctly" $ do
((res, _), _) <- evaluate "next.rb" ((res, heap), _) <- evaluate ["next.rb"]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 8)] 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 it "calls functions with arguments" $ do
((res, _), _) <- evaluate "call.rb" ((res, heap), _) <- evaluate ["call.rb"]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 579)] 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 it "evaluates early return statements" $ do
((res, _), _) <- evaluate "early-return.rb" ((res, heap), _) <- evaluate ["early-return.rb"]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 123)] 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 it "has prelude" $ do
((res, _), _) <- evaluate "preluded.rb" ((res, heap), _) <- evaluate ["preluded.rb"]
fmap fst <$> res `shouldBe` Right [String "\"<foo>\""] case ModuleTable.lookup "preluded.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"<foo>\""]
other -> expectationFailure (show other)
it "evaluates __LINE__" $ do it "evaluates __LINE__" $ do
((res, _), _) <- evaluate "line.rb" ((res, heap), _) <- evaluate ["line.rb"]
fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 4)] 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 it "resolves builtins used in the prelude" $ do
((res, _), traces) <- evaluate "puts.rb" ((res, heap), traces) <- evaluate ["puts.rb"]
fmap fst <$> res `shouldBe` Right [Unit] case ModuleTable.lookup "puts.rb" <$> res of
Right (Just (Module _ (addr, env) :| [])) -> do
heapLookupAll addr heap `shouldBe` Just [Unit]
traces `shouldContain` [ "\"hello\"" ] traces `shouldContain` [ "\"hello\"" ]
other -> expectationFailure (show other)
where where
ns n = Just . Latest . Last . Just . Namespace n ns n = Just . Latest . Last . Just . Namespace n
fixtures = "test/fixtures/ruby/analysis/" fixtures = "test/fixtures/ruby/analysis/"
evaluate entry = evalRubyProject (fixtures <> entry) evaluate = evalRubyProject . map (fixtures <>)
evalRubyProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby path evalRubyProject = testEvaluating <=< evaluateProject (Proxy :: Proxy 'Language.Ruby) rubyParser Language.Ruby

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

@ -3,41 +3,50 @@ module Analysis.TypeScript.Spec (spec) where
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Data.Abstract.Environment as Env import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable import Data.Abstract.Evaluatable
import qualified Language.TypeScript.Assignment as TypeScript
import Data.Abstract.Value as Value import Data.Abstract.Value as Value
import Data.Abstract.Number as Number import Data.Abstract.Number as Number
import qualified Data.Abstract.ModuleTable as ModuleTable
import qualified Data.Language as Language import qualified Data.Language as Language
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sum import Data.Sum
import SpecHelpers import SpecHelpers
spec :: Spec spec :: Spec
spec = parallel $ do spec = parallel $ do
describe "evaluates TypeScript" $ do describe "TypeScript" $ do
it "imports with aliased symbols" $ do it "imports with aliased symbols" $ do
((Right [(_, env)], _), _) <- evaluate "main.ts" ((res, _), _) <- evaluate ["main.ts", "foo.ts", "a.ts", "foo/b.ts"]
Env.names env `shouldBe` [ "bar", "quz" ] 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 it "imports with qualified names" $ do
((Right [(_, env)], state), _) <- evaluate "main1.ts" ((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" ] Env.names env `shouldBe` [ "b", "z" ]
(derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) (derefQName heap ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
(derefQName (heap state) ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) (derefQName heap ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ])
other -> expectationFailure (show other)
it "side effect only imports" $ do it "side effect only imports" $ do
((res, _), _) <- evaluate "main2.ts" ((res, _), _) <- evaluate ["main2.ts", "a.ts", "foo.ts"]
fmap snd <$> res `shouldBe` Right [lowerBound] 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 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")))) res `shouldBe` Left (SomeExc (inject @EvalError (ExportError "foo.ts" (name "pip"))))
it "evaluates early return statements" $ do it "evaluates early return statements" $ do
((res, _), _) <- evaluate "early-return.ts" ((res, heap), _) <- evaluate ["early-return.ts"]
fmap fst <$> res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] 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 where
fixtures = "test/fixtures/typescript/analysis/" fixtures = "test/fixtures/typescript/analysis/"
evaluate entry = evalTypeScriptProject (fixtures <> entry) evaluate = evalTypeScriptProject . map (fixtures <>)
evalTypeScriptProject path = testEvaluating <$> evaluateProject (Proxy :: Proxy 'Language.TypeScript) typescriptParser Language.TypeScript path 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(..) , SpecEff(..)
) where ) where
import Analysis.Abstract.Evaluating (evaluating)
import Control.Abstract import Control.Abstract
import Data.Abstract.Module import Data.Abstract.Module
import qualified Data.Abstract.Number as Number import qualified Data.Abstract.Number as Number
@ -30,14 +29,15 @@ spec = parallel $ do
evaluate evaluate
= runM = runM
. evaluating @Precise @Val . runState (lowerBound @(Heap Precise Latest Val))
. runReader (PackageInfo (name "test") Nothing mempty) . runFresh 0
. runReader (PackageInfo (name "test") mempty)
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs") . runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
. fmap reassociate . fmap reassociate
. runValueError . runValueError
. runEnvironmentError . runEnvironmentError
. runAddressError . runAddressError
. runAllocator . runAllocator @Precise @_ @Val
. (>>= deref . fst) . (>>= deref . fst)
. runEnv lowerBound . runEnv lowerBound
. runReturn . runReturn
@ -59,7 +59,6 @@ newtype SpecEff a = SpecEff
, Reader PackageInfo , Reader PackageInfo
, Fresh , Fresh
, State (Heap Precise Latest Val) , State (Heap Precise Latest Val)
, State (ModuleTable (Maybe (Precise, Environment Precise)))
, IO , IO
] a ] a
} }

1
test/Doctests.hs
View File

@ -9,6 +9,7 @@ defaultFiles =
[ "src/Data/Abstract/Address.hs" [ "src/Data/Abstract/Address.hs"
, "src/Data/Abstract/Environment.hs" , "src/Data/Abstract/Environment.hs"
, "src/Data/Abstract/Name.hs" , "src/Data/Abstract/Name.hs"
, "src/Data/Graph.hs"
, "src/Data/Range.hs" , "src/Data/Range.hs"
, "src/Data/Semigroup/App.hs" , "src/Data/Semigroup/App.hs"
] ]

74
test/SpecHelpers.hs
View File

@ -9,12 +9,10 @@ module SpecHelpers
, derefQName , derefQName
, verbatim , verbatim
, TermEvaluator(..) , TermEvaluator(..)
, TestEff(..)
, Verbatim(..) , Verbatim(..)
, toList
) where ) where
import Analysis.Abstract.Evaluating
import Analysis.Abstract.Evaluating as X (EvaluatingState(..))
import Control.Abstract import Control.Abstract
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Control.Monad.Effect.Trace as X (runIgnoringTrace, runReturningTrace) 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.Evaluatable
import Data.Abstract.FreeVariables as X import Data.Abstract.FreeVariables as X
import Data.Abstract.Heap 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.ModuleTable as X hiding (lookup)
import Data.Abstract.Name as X import Data.Abstract.Name as X
import Data.Abstract.Value (Value(..), ValueError, runValueError) import Data.Abstract.Value (Value(..), ValueError, runValueError)
@ -33,6 +32,7 @@ import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy (toStrict)
import Data.Project as X import Data.Project as X
import Data.Proxy as X import Data.Proxy as X
import Data.Foldable (toList)
import Data.Functor.Listable as X import Data.Functor.Listable as X
import Data.Language as X import Data.Language as X
import Data.List.NonEmpty as X (NonEmpty(..)) import Data.List.NonEmpty as X (NonEmpty(..))
@ -81,38 +81,39 @@ readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap file paths in readFilePair paths = let paths' = fmap file paths in
runBothWith IO.readFilePair paths' runBothWith IO.readFilePair paths'
testEvaluating :: TermEvaluator term Precise type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise))
Val
'[ Resumable (ValueError Precise TestEff)
, Resumable (AddressError Precise Val) , Resumable (AddressError Precise Val)
, Resumable EvalError, Resumable (EnvironmentError Precise) , Resumable EvalError, Resumable (EnvironmentError Precise)
, Resumable ResolutionError , Resumable ResolutionError
, Resumable (Unspecialized Val) , Resumable (Unspecialized Val)
, Resumable (LoadError Precise Val) , Resumable (LoadError Precise)
, Trace
, Fresh , Fresh
, State (Heap Precise Latest Val) , State (Heap Precise Latest Val)
, State (ModuleTable (Maybe (Precise, Environment Precise))) , IO
, Trace
] ]
[(Precise, Environment Precise)] type TestEvaluatingErrors = '[ ValueError Precise (UtilEff Precise)
-> ((Either
(SomeExc
(Data.Sum.Sum
'[ ValueError Precise TestEff
, AddressError Precise Val , AddressError Precise Val
, EvalError , EvalError
, EnvironmentError Precise , EnvironmentError Precise
, ResolutionError , ResolutionError
, Unspecialized Val , Unspecialized Val
, LoadError Precise Val , LoadError Precise
])) ]
[(Value Precise TestEff, Environment Precise)], testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (Precise, Environment Precise))))
EvaluatingState Precise Val), -> IO
[String]) ( ( Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
(ModuleTable (NonEmpty (Module (Precise, Environment Precise))))
, Heap Precise Latest Val
)
, [String]
)
testEvaluating testEvaluating
= run = runM
. fmap (\ ((res, traces), heap) -> ((res, heap), traces))
. runState lowerBound
. runFresh 0
. runReturningTrace . runReturningTrace
. evaluating
. fmap reassociate . fmap reassociate
. runLoadError . runLoadError
. runUnspecialized . runUnspecialized
@ -120,37 +121,10 @@ testEvaluating
. runEnvironmentError . runEnvironmentError
. runEvalError . runEvalError
. runAddressError . runAddressError
. runValueError . runValueError @_ @Precise @(UtilEff Precise)
. (>>= traverse deref1)
. runTermEvaluator @_ @_ @Val
type Val = Value Precise TestEff type Val = Value Precise (UtilEff Precise)
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
}
deref1 (ptr, env) = runAllocator $ do
val <- deref ptr
pure (val, env)
deNamespace :: Value Precise term -> Maybe (Name, [Name]) deNamespace :: Value Precise term -> Maybe (Name, [Name])
deNamespace (Namespace name scope) = Just (name, Env.names scope) deNamespace (Namespace name scope) = Just (name, Env.names scope)