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

Merge branch 'master' into splunk-docs

Browse Source
This commit is contained in:
Rob Rix 2018-08-09 09:37:38 -04:00 committed by GitHub
commit 380d2164e8
25 changed files with 416 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic.cabal
View File

@ -49,6 +49,7 @@ library
, Control.Abstract.Value
-- Datatypes for abstract interpretation
, Data.Abstract.Address
, Data.Abstract.BaseError
, Data.Abstract.Cache
, Data.Abstract.Configuration
, Data.Abstract.Declarations

5
src/Analysis/Abstract/Caching.hs
View File

@ -7,6 +7,7 @@ module Analysis.Abstract.Caching
import Control.Abstract
import Data.Abstract.Cache
import Data.Abstract.BaseError
import Data.Abstract.Module
import Data.Abstract.Ref
import Prologue
@ -81,7 +82,9 @@ convergingModules :: ( AbstractValue address value effects
, Member NonDet effects
, Member (Reader (Cache term address (Cell address) value)) effects
, Member (Reader (Live address)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (State (Cache term address (Cell address) value)) effects
, Member (Env address) effects
, Member (State (Heap address (Cell address) value)) effects

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

@ -19,6 +19,7 @@ module Analysis.Abstract.Graph
import Algebra.Graph.Export.Dot hiding (vertexName)
import Control.Abstract hiding (Function(..))
import Data.Abstract.Address
import Data.Abstract.BaseError
import Data.Abstract.Ref
import Data.Abstract.Declarations
import Data.Abstract.Module (Module (moduleInfo), ModuleInfo (..))
@ -60,10 +61,11 @@ style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier))
-- | Add vertices to the graph for evaluated identifiers.
graphingTerms :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Env (Hole context (Located address))) effects
, Member (State (Graph Vertex)) effects
, Member (State (Map (Hole context (Located address)) Vertex)) effects
, Member (Resumable (EnvironmentError (Hole context (Located address)))) effects
, Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) effects
, AbstractValue (Hole context (Located address)) value effects
, Member (Reader Vertex) effects
, HasField fields Span

33
src/Control/Abstract/Environment.hs
View File

@ -23,10 +23,13 @@ module Control.Abstract.Environment
) where
import Control.Abstract.Evaluator
import Data.Abstract.BaseError
import Data.Abstract.Environment (Bindings, Environment, EvalContext(..))
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Exports as Exports
import Data.Abstract.Module
import Data.Abstract.Name
import Data.Span
import Prologue
-- | Retrieve the current execution context
@ -114,7 +117,9 @@ runEnv initial = fmap (filterEnv . fmap (first (Env.head . ctxEnvironment))) . r
| Exports.null ports = (binds, a)
| otherwise = (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds, a)
handleEnv :: forall address value effects a . Effects effects => Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (EvalContext address) ': State (Exports address) ': effects) a
handleEnv :: forall address value effects a . Effects effects
=> Env address (Eff (Env address ': effects)) a
-> Evaluator address value (State (EvalContext address) ': State (Exports address) ': effects) a
handleEnv = \case
Lookup name -> Env.lookupEnv' name . ctxEnvironment <$> get
Bind name addr -> modify (\EvalContext{..} -> EvalContext ctxSelf (Env.insertEnv name addr ctxEnvironment))
@ -136,11 +141,29 @@ deriving instance Show (EnvironmentError address return)
instance Show1 (EnvironmentError address) where liftShowsPrec _ _ = showsPrec
instance Eq1 (EnvironmentError address) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
freeVariableError :: Member (Resumable (EnvironmentError address)) effects => Name -> Evaluator address value effects address
freeVariableError = throwResumable . FreeVariable
freeVariableError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> Name
-> Evaluator address value effects address
freeVariableError = throwEnvironmentError . FreeVariable
runEnvironmentError :: (Effectful (m address value), Effects effects) => m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects (Either (SomeExc (EnvironmentError address)) a)
runEnvironmentError :: (Effectful (m address value), Effects effects)
=> m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (EnvironmentError address))) a)
runEnvironmentError = runResumable
runEnvironmentErrorWith :: (Effectful (m address value), Effects effects) => (forall resume . EnvironmentError address resume -> m address value effects resume) -> m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects a
runEnvironmentErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . BaseError (EnvironmentError address) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (EnvironmentError address)) ': effects) a
-> m address value effects a
runEnvironmentErrorWith = runResumableWith
throwEnvironmentError :: ( Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> EnvironmentError address resume
-> Evaluator address value effects resume
throwEnvironmentError = throwBaseError

31
src/Control/Abstract/Heap.hs
View File

@ -31,10 +31,13 @@ import Control.Abstract.Evaluator
import Control.Abstract.Roots
import Control.Abstract.TermEvaluator
import Data.Abstract.Configuration
import Data.Abstract.BaseError
import Data.Abstract.Heap
import Data.Abstract.Live
import Data.Abstract.Module (ModuleInfo)
import Data.Abstract.Name
import Data.Semigroup.Reducer
import Data.Span (Span)
import Prologue
-- | Get the current 'Configuration' with a passed-in term.
@ -117,7 +120,9 @@ letrec' name body = do
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: ( Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> Name
-> Evaluator address value effects address
@ -177,13 +182,15 @@ runAllocator = interpret $ \ eff -> case eff of
runDeref :: ( Derefable address effects
, PureEffects effects
, Member (Resumable (AddressError address value)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (State (Heap address (Cell address) value)) effects
)
=> Evaluator address value (Deref address value ': effects) a
-> Evaluator address value effects a
runDeref = interpret $ \ eff -> case eff of
Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))
Deref addr -> heapLookup addr <$> get >>= maybeM (throwAddressError (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwAddressError (UninitializedAddress addr))
instance PureEffect (Allocator address value)
@ -210,9 +217,23 @@ instance Eq address => Eq1 (AddressError address value) where
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
liftEq _ _ _ = False
throwAddressError :: ( Member (Resumable (BaseError (AddressError address body))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> AddressError address body resume
-> Evaluator address value effects resume
throwAddressError = throwBaseError
runAddressError :: (Effectful (m address value), Effects effects) => m address value (Resumable (AddressError address value) ': effects) a -> m address value effects (Either (SomeExc (AddressError address value)) a)
runAddressError :: ( Effectful (m address value)
, Effects effects
)
=> m address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (AddressError address value))) a)
runAddressError = runResumable
runAddressErrorWith :: (Effectful (m address value), Effects effects) => (forall resume . AddressError address value resume -> m address value effects resume) -> m address value (Resumable (AddressError address value) ': effects) a -> m address value effects a
runAddressErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . (BaseError (AddressError address value)) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> m address value effects a
runAddressErrorWith = runResumableWith

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

@ -9,22 +9,25 @@ module Control.Abstract.Modules
, Modules(..)
, runModules
, LoadError(..)
, moduleNotFound
, runLoadError
, runLoadErrorWith
, throwLoadError
, ResolutionError(..)
, runResolutionError
, runResolutionErrorWith
, throwResolutionError
, ModuleTable
) where
import Control.Abstract.Evaluator
import Data.Abstract.Environment
import Data.Abstract.BaseError
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Language
import Data.Semigroup.Foldable (foldMap1)
import qualified Data.Set as Set
import Data.Span
import Prologue
import System.FilePath.Posix (takeDirectory)
@ -72,14 +75,14 @@ sendModules :: Member (Modules address) effects => Modules address (Eff effects)
sendModules = send
runModules :: ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects
, Member (Resumable (LoadError address)) effects
, Member (Resumable (BaseError (LoadError address))) effects
, PureEffects effects
)
=> Set ModulePath
-> Evaluator address value (Modules address ': effects) a
-> Evaluator address value effects a
runModules paths = interpret $ \case
Load name -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (moduleNotFound name)
Load name -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name <$> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name))
Lookup path -> fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path <$> askModuleTable
Resolve names -> pure (find (`Set.member` paths) names)
List dir -> pure (filter ((dir ==) . takeDirectory) (toList paths))
@ -96,24 +99,31 @@ instance Semigroup (Merging address) where
-- | 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 resume where
ModuleNotFound :: ModulePath -> LoadError address (ModuleResult address)
ModuleNotFoundError :: ModulePath -> LoadError address (ModuleResult address)
deriving instance Eq (LoadError address resume)
deriving instance Show (LoadError address resume)
instance Show1 (LoadError address) where
liftShowsPrec _ _ = showsPrec
instance Eq1 (LoadError address) where
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
liftEq _ (ModuleNotFoundError a) (ModuleNotFoundError b) = a == b
moduleNotFound :: Member (Resumable (LoadError address)) effects => ModulePath -> Evaluator address value effects (ModuleResult address)
moduleNotFound = throwResumable . ModuleNotFound
runLoadError :: (Effectful (m address value), Effects effects) => m address value (Resumable (LoadError address) ': effects) a -> m address value effects (Either (SomeExc (LoadError address)) a)
runLoadError :: (Effectful (m address value), Effects effects)
=> m address value (Resumable (BaseError (LoadError address)) ': effects) a
-> m address value effects (Either (SomeExc (BaseError (LoadError address))) a)
runLoadError = runResumable
runLoadErrorWith :: (Effectful (m address value), Effects effects) => (forall resume . LoadError address resume -> m address value effects resume) -> m address value (Resumable (LoadError address) ': effects) a -> m address value effects a
runLoadErrorWith :: (Effectful (m address value), Effects effects)
=> (forall resume . (BaseError (LoadError address)) resume -> m address value effects resume)
-> m address value (Resumable (BaseError (LoadError address)) ': effects) a
-> m address value effects a
runLoadErrorWith = runResumableWith
throwLoadError :: Member (Resumable (BaseError (LoadError address))) effects
=> LoadError address resume
-> Evaluator address value effects resume
throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name) emptySpan err
-- | An error thrown when we can't resolve a module from a qualified name.
data ResolutionError resume where
@ -132,8 +142,21 @@ instance Eq1 ResolutionError where
liftEq _ (GoImportError a) (GoImportError b) = a == b
liftEq _ _ _ = False
runResolutionError :: (Effectful m, Effects effects) => m (Resumable ResolutionError ': effects) a -> m effects (Either (SomeExc ResolutionError) a)
runResolutionError :: (Effectful m, Effects effects)
=> m (Resumable (BaseError ResolutionError) ': effects) a
-> m effects (Either (SomeExc (BaseError ResolutionError)) a)
runResolutionError = runResumable
runResolutionErrorWith :: (Effectful m, Effects effects) => (forall resume . ResolutionError resume -> m effects resume) -> m (Resumable ResolutionError ': effects) a -> m effects a
runResolutionErrorWith :: (Effectful m, Effects effects)
=> (forall resume . (BaseError ResolutionError) resume -> m effects resume)
-> m (Resumable (BaseError ResolutionError) ': effects) a
-> m effects a
runResolutionErrorWith = runResumableWith
throwResolutionError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
)
=> ResolutionError resume
-> Evaluator address value effects resume
throwResolutionError = throwBaseError

5
src/Control/Abstract/Primitive.hs
View File

@ -15,6 +15,7 @@ import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Control.Abstract.Value
import qualified Data.Abstract.Environment as Env
import Data.Abstract.BaseError
import Data.Abstract.Name
import Data.Text (unpack)
import Prologue
@ -99,7 +100,7 @@ builtInPrint :: ( AbstractValue address value effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member Trace effects
)
=> Evaluator address value effects value
@ -114,7 +115,7 @@ builtInExport :: ( AbstractValue address value effects
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> Evaluator address value effects value
builtInExport = lambda (\ v -> do

19
src/Control/Abstract/Value.hs
View File

@ -23,10 +23,13 @@ import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Abstract.Heap
import Data.Abstract.Environment as Env
import Data.Abstract.BaseError
import Data.Abstract.Module
import Data.Abstract.Name
import Data.Abstract.Number as Number
import Data.Abstract.Ref
import Data.Scientific (Scientific)
import Data.Span
import Prologue hiding (TypeError)
-- | This datum is passed into liftComparison to handle the fact that Ruby and PHP
@ -228,7 +231,9 @@ evaluateInScopedEnv receiver term = do
value :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> ValueRef address
-> Evaluator address value effects value
@ -238,7 +243,9 @@ value = deref <=< address
subtermValue :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> Evaluator address value effects value
@ -247,7 +254,9 @@ subtermValue = value <=< subtermRef
-- | Returns the address of a value referenced by a 'ValueRef'
address :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> ValueRef address
-> Evaluator address value effects address
@ -258,7 +267,9 @@ address (Rval addr) = pure addr
-- | Evaluates a 'Subterm' to the address of its rval
subtermAddress :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
)
=> Subterm term (Evaluator address value effects (ValueRef address))
-> Evaluator address value effects address

41
src/Data/Abstract/BaseError.hs Normal file
View File

@ -0,0 +1,41 @@
{-# LANGUAGE KindSignatures #-}
module Data.Abstract.BaseError (
BaseError(..)
, throwBaseError
)
where
import Control.Abstract.Context
import Control.Abstract.Evaluator
import qualified Data.Abstract.Module as M
import qualified Data.Span as S
import Prologue
data BaseError (exc :: * -> *) resume = BaseError { baseErrorModuleInfo :: ModuleInfo, baseErrorSpan :: Span, baseErrorException :: exc resume }
instance (Show (exc resume)) => Show (BaseError exc resume) where
showsPrec _ BaseError{..} = shows baseErrorException <> showString " " <> showString errorLocation
where errorLocation | startErrorLine == endErrorLine = M.modulePath baseErrorModuleInfo <> " " <> startErrorLine <> ":" <> startErrorCol <> "-" <> endErrorCol
| otherwise = M.modulePath baseErrorModuleInfo <> " " <> startErrorLine <> ":" <> startErrorCol <> "-" <> endErrorLine <> ":" <> endErrorCol
startErrorLine = show $ S.posLine (S.spanStart baseErrorSpan)
endErrorLine = show $ S.posLine (S.spanEnd baseErrorSpan)
startErrorCol = show $ S.posColumn (S.spanStart baseErrorSpan)
endErrorCol = show $ S.posColumn (S.spanEnd baseErrorSpan)
instance (Eq1 exc) => Eq1 (BaseError exc) where
liftEq f (BaseError _ _ exc1) (BaseError _ _ exc2) = liftEq f exc1 exc2
instance Show1 exc => Show1 (BaseError exc) where
liftShowsPrec sl sp d (BaseError _ _ exc) = liftShowsPrec sl sp d exc
throwBaseError :: ( Member (Resumable (BaseError exc)) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader S.Span) effects
)
=> exc resume
-> Evaluator address value effects resume
throwBaseError err = do
moduleInfo <- currentModule
span <- currentSpan
throwResumable $ BaseError moduleInfo span err

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

@ -13,9 +13,10 @@ module Data.Abstract.Evaluatable
, throwEvalError
, runEvalError
, runEvalErrorWith
, Unspecialized(..)
, UnspecializedError(..)
, runUnspecialized
, runUnspecializedWith
, throwUnspecializedError
, Cell
) where
@ -24,10 +25,11 @@ import Control.Abstract.Context as X
import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith)
import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn)
import Control.Abstract.Heap as X hiding (AddressError(..), runAddressError, runAddressErrorWith)
import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve)
import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError)
import Control.Abstract.Value as X hiding (Function(..))
import Data.Abstract.Declarations as X
import Data.Abstract.Environment as X
import Data.Abstract.BaseError as X
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
@ -58,17 +60,17 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable (Unspecialized value)) effects
, Member (Resumable EvalError) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (Resumable (BaseError EvalError)) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Fresh effects
, Member Trace effects
)
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
eval expr = do
traverse_ subtermValue expr
v <- throwResumable (Unspecialized ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr ""))
v <- throwUnspecializedError $ UnspecializedError ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "")
rvalBox v
@ -87,11 +89,11 @@ evaluate :: ( AbstractValue address value valueEffects
, Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects
, Member (Reader PackageInfo) effects
, Member (Reader Span) effects
, Member (Resumable (AddressError address value)) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable EvalError) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (Unspecialized value)) effects
, Member (Resumable (BaseError (AddressError address value))) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member (Resumable (BaseError EvalError)) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (State (Heap address (Cell address) value)) effects
, Member Trace effects
, Recursive term
@ -101,7 +103,7 @@ evaluate :: ( AbstractValue address value valueEffects
, valueEffects ~ (Function address value ': moduleEffects)
)
=> proxy lang
-> (SubtermAlgebra Module term (TermEvaluator term address value moduleEffects address) -> SubtermAlgebra Module term (TermEvaluator term address value moduleEffects address))
-> (SubtermAlgebra Module term (TermEvaluator term address value moduleEffects address) -> SubtermAlgebra Module term (TermEvaluator term address value moduleEffects address))
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value valueEffects (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value valueEffects (ValueRef address)))
-> (forall x . Evaluator address value valueEffects x -> Evaluator address value moduleEffects x)
-> [Module term]
@ -148,7 +150,7 @@ class HasPrelude (language :: Language) where
, Member (Function address value) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member Trace effects
)
=> proxy language
@ -192,7 +194,7 @@ class HasPostlude (language :: Language) where
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member Trace effects
)
=> proxy language
@ -238,34 +240,52 @@ instance Eq1 EvalError where
instance Show1 EvalError where
liftShowsPrec _ _ = showsPrec
throwEvalError :: (Effectful m, Member (Resumable EvalError) effects) => EvalError resume -> m effects resume
throwEvalError = throwResumable
runEvalError :: (Effectful m, Effects effects) => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a)
runEvalError :: (Effectful m, Effects effects) => m (Resumable (BaseError EvalError) ': effects) a -> m effects (Either (SomeExc (BaseError EvalError)) a)
runEvalError = runResumable
runEvalErrorWith :: (Effectful m, Effects effects) => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a
runEvalErrorWith :: (Effectful m, Effects effects) => (forall resume . (BaseError EvalError) resume -> m effects resume) -> m (Resumable (BaseError EvalError) ': effects) a -> m effects a
runEvalErrorWith = runResumableWith
throwEvalError :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError EvalError)) effects
)
=> EvalError resume
-> Evaluator address value effects resume
throwEvalError = throwBaseError
data Unspecialized a b where
Unspecialized :: String -> Unspecialized value value
deriving instance Eq (Unspecialized a b)
deriving instance Show (Unspecialized a b)
data UnspecializedError a b where
UnspecializedError :: String -> UnspecializedError value value
instance Eq1 (Unspecialized a) where
liftEq _ (Unspecialized a) (Unspecialized b) = a == b
deriving instance Eq (UnspecializedError a b)
deriving instance Show (UnspecializedError a b)
instance Show1 (Unspecialized a) where
instance Eq1 (UnspecializedError a) where
liftEq _ (UnspecializedError a) (UnspecializedError b) = a == b
instance Show1 (UnspecializedError a) where
liftShowsPrec _ _ = showsPrec
runUnspecialized :: (Effectful (m value), Effects effects) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a)
runUnspecialized :: (Effectful (m value), Effects effects)
=> m value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> m value effects (Either (SomeExc (BaseError (UnspecializedError value))) a)
runUnspecialized = runResumable
runUnspecializedWith :: (Effectful (m value), Effects effects) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a
runUnspecializedWith :: (Effectful (m value), Effects effects)
=> (forall resume . BaseError (UnspecializedError value) resume -> m value effects resume)
-> m value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> m value effects a
runUnspecializedWith = runResumableWith
throwUnspecializedError :: ( Member (Resumable (BaseError (UnspecializedError value))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> UnspecializedError value resume
-> Evaluator address value effects resume
throwUnspecializedError = throwBaseError
-- Instances

37
src/Data/Abstract/Value/Concrete.hs
View File

@ -7,11 +7,11 @@ module Data.Abstract.Value.Concrete
, materializeEnvironment
, runValueError
, runValueErrorWith
, throwValueError
) where
import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Function(..))
import Data.Abstract.BaseError
import Data.Abstract.Environment (Environment, Bindings, EvalContext(..))
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Name
@ -67,7 +67,8 @@ runFunction :: ( Member (Allocator address (Value address body)) effects
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError address body)) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, PureEffects effects
)
=> (body address -> Evaluator address (Value address body) (Abstract.Function address (Value address body) ': effects) address)
@ -142,7 +143,8 @@ instance ( Coercible body (Eff effects)
, Member Fresh effects
, Member (Reader ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable (ValueError address body)) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
, Show address
)
=> AbstractValue address (Value address body) effects where
@ -214,7 +216,13 @@ instance ( Coercible body (Eff effects)
tentative x i j = attemptUnsafeArithmetic (x i j)
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
specialize :: (AbstractValue address (Value address body) effects, Member (Resumable (ValueError address body)) effects) => Either ArithException Number.SomeNumber -> Evaluator address (Value address body) effects (Value address body)
specialize :: ( AbstractValue address (Value address body) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError (ValueError address body))) effects
)
=> Either ArithException Number.SomeNumber
-> Evaluator address (Value address body) effects (Value address body)
specialize (Left exc) = throwValueError (ArithmeticError exc)
specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i
specialize (Right (Number.SomeNumber (Number.Ratio r))) = pure $ rational r
@ -244,7 +252,6 @@ instance ( Coercible body (Eff effects)
pair = (left, right)
liftBitwise operator target
| Integer (Number.Integer i) <- target = pure . integer $ operator i
| otherwise = throwValueError (BitwiseError target)
@ -297,11 +304,21 @@ deriving instance Show address => Show (ValueError address body resume)
instance Show address => Show1 (ValueError address body) where
liftShowsPrec _ _ = showsPrec
throwValueError :: Member (Resumable (ValueError address body)) effects => ValueError address body resume -> Evaluator address (Value address body) effects resume
throwValueError = throwResumable
runValueError :: (Effectful (m address (Value address body)), Effects effects) => m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects (Either (SomeExc (ValueError address body)) a)
runValueError :: (Effectful (m address (Value address body)), Effects effects)
=> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects (Either (SomeExc (BaseError (ValueError address body))) a)
runValueError = runResumable
runValueErrorWith :: (Effectful (m address (Value address body)), Effects effects) => (forall resume . ValueError address body resume -> m address (Value address body) effects resume) -> m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects a
runValueErrorWith :: (Effectful (m address (Value address body)), Effects effects)
=> (forall resume . BaseError (ValueError address body) resume -> m address (Value address body) effects resume)
-> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects a
runValueErrorWith = runResumableWith
throwValueError :: ( Member (Resumable (BaseError (ValueError address body))) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> ValueError address body resume
-> Evaluator address (Value address body) effects resume
throwValueError = throwBaseError

51
src/Data/Abstract/Value/Type.hs
View File

@ -13,6 +13,7 @@ import qualified Control.Abstract as Abstract
import Control.Abstract hiding (Function(..), raiseHandler)
import Control.Monad.Effect.Internal (raiseHandler)
import Data.Abstract.Environment as Env
import Data.Abstract.BaseError
import Data.Semigroup.Foldable (foldMap1)
import qualified Data.Map as Map
import Prologue hiding (TypeError)
@ -84,12 +85,20 @@ instance Ord1 TypeError where
instance Show1 TypeError where liftShowsPrec _ _ = showsPrec
runTypeError :: (Effectful m, Effects effects) => m (Resumable TypeError ': effects) a -> m effects (Either (SomeExc TypeError) a)
runTypeError :: (Effectful m, Effects effects) => m (Resumable (BaseError TypeError) ': effects) a -> m effects (Either (SomeExc (BaseError TypeError)) a)
runTypeError = runResumable
runTypeErrorWith :: (Effectful m, Effects effects) => (forall resume . TypeError resume -> m effects resume) -> m (Resumable TypeError ': effects) a -> m effects a
runTypeErrorWith :: (Effectful m, Effects effects) => (forall resume . (BaseError TypeError) resume -> m effects resume) -> m (Resumable (BaseError TypeError) ': effects) a -> m effects a
runTypeErrorWith = runResumableWith
throwTypeError :: ( Member (Resumable (BaseError TypeError)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
)
=> TypeError resume
-> Evaluator address value effects resume
throwTypeError = throwBaseError
runTypeMap :: ( Effectful m
, Effects effects
)
@ -100,15 +109,15 @@ runTypeMap = raiseHandler (runState emptyTypeMap >=> pure . snd)
runTypes :: ( Effectful m
, Effects effects
)
=> m (Resumable TypeError ': State TypeMap ': effects) a
-> m effects (Either (SomeExc TypeError) a)
=> m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> m effects (Either (SomeExc (BaseError TypeError)) a)
runTypes = runTypeMap . runTypeError
runTypesWith :: ( Effectful m
, Effects effects
)
=> (forall resume . TypeError resume -> m (State TypeMap ': effects) resume)
-> m (Resumable TypeError ': State TypeMap ': effects) a
=> (forall resume . (BaseError TypeError) resume -> m (State TypeMap ': effects) resume)
-> m (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> m effects a
runTypesWith with = runTypeMap . runTypeErrorWith with
@ -173,31 +182,31 @@ occur id = prune >=> \case
eitherM f (a, b) = (||) <$> f a <*> f b
-- | Substitutes a type variable name for another type
substitute :: ( Effectful m
, Monad (m effects)
, Member (Resumable TypeError) effects
substitute :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
)
=> TName
-> Type
-> m effects Type
-> Evaluator address value effects Type
substitute id ty = do
infiniteType <- occur id ty
ty <- if infiniteType
then throwResumable (InfiniteType (Var id) ty)
then throwTypeError (InfiniteType (Var id) ty)
else pure ty
modifyTypeMap (Map.insert id ty)
pure ty
-- | Unify two 'Type's.
unify :: ( Effectful m
, Monad (m effects)
, Member (Resumable TypeError) effects
unify :: ( Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
)
=> Type
-> Type
-> m effects Type
-> Evaluator address value effects Type
unify a b = do
a' <- prune a
b' <- prune b
@ -213,7 +222,7 @@ unify a b = do
(a1 :+ b1, a2 :+ b2) -> (:+) <$> unify a1 a2 <*> unify b1 b2
(a1 :* b1, a2 :* b2) -> (:*) <$> unify a1 a2 <*> unify b1 b2
(t1, t2) | t1 == t2 -> pure t2
_ -> throwResumable (UnificationError a b)
_ -> throwTypeError (UnificationError a b)
instance Ord address => ValueRoots address Type where
valueRoots _ = mempty
@ -224,7 +233,9 @@ runFunction :: ( Member (Allocator address Type) effects
, Member (Env address) effects
, Member (Exc (Return address)) effects
, Member Fresh effects
, Member (Resumable TypeError) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
, PureEffects effects
)
@ -245,7 +256,7 @@ runFunction = interpret $ \case
unified <- op `unify` needed
case unified of
_ :-> ret -> box ret
actual -> throwResumable (UnificationError needed actual) >>= box
actual -> throwTypeError (UnificationError needed actual) >>= box
instance AbstractHole Type where
@ -270,7 +281,9 @@ instance ( Member (Allocator address Type) effects
, Member (Deref address Type) effects
, Member Fresh effects
, Member NonDet effects
, Member (Resumable TypeError) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError TypeError)) effects
, Member (State TypeMap) effects
)
=> AbstractValue address Type effects where

2
src/Data/Syntax/Expression.hs
View File

@ -393,7 +393,7 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
-- TODO return a special LvalSubscript instance here
instance Evaluatable Subscript where
eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript _ _) = rvalBox =<< throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
eval (Subscript _ _) = rvalBox =<< throwUnspecializedError (UnspecializedError "Eval unspecialized for subscript with slices")
data Member a = Member { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)

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

@ -2,6 +2,7 @@
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Language.Go.Syntax where
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import qualified Data.Abstract.Package as Package
@ -31,7 +32,8 @@ defaultAlias = name . T.pack . takeFileName . unPath
resolveGoImport :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Package.PackageInfo) effects
, Member (Resumable ResolutionError) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
)
=> ImportPath
@ -40,7 +42,7 @@ resolveGoImport (ImportPath path Relative) = do
ModuleInfo{..} <- currentModule
paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)
case paths of
[] -> throwResumable $ GoImportError path
[] -> throwResolutionError $ GoImportError path
_ -> pure paths
resolveGoImport (ImportPath path NonRelative) = do
package <- T.unpack . formatName . Package.packageName <$> currentPackage
@ -50,7 +52,7 @@ resolveGoImport (ImportPath path NonRelative) = do
-- First two are source, next is package name, remaining are path to package
-- (e.g. github.com/golang/<package>/path...).
(_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs)
_ -> throwResumable $ GoImportError path
_ -> throwResolutionError $ GoImportError path
-- | Import declarations (symbols are added directly to the calling environment).
--

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

@ -2,7 +2,7 @@
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Language.PHP.Syntax where
import Control.Abstract.Modules
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import Data.Abstract.Path
@ -38,13 +38,15 @@ instance Evaluatable VariableName
-- were defined inside that function.
resolvePHPName :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
)
=> T.Text
-> Evaluator address value effects ModulePath
resolvePHPName n = do
modulePath <- resolve [name]
maybeM (throwResumable $ NotFoundError name [name] Language.PHP) modulePath
maybeM (throwResolutionError $ NotFoundError name [name] Language.PHP) modulePath
where name = toName n
toName = T.unpack . dropRelativePrefix . stripQuotes
@ -52,8 +54,10 @@ include :: ( AbstractValue address value effects
, Member (Deref address value) effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (Resumable ResolutionError) effects
, Member (Resumable (EnvironmentError address)) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member (Resumable (BaseError (EnvironmentError address))) effects
, Member Trace effects
)
=> Subterm term (Evaluator address value effects (ValueRef address))
@ -375,12 +379,12 @@ instance Evaluatable Namespace where
where
-- Each namespace name creates a closure over the subsequent namespace closures
go (n:x:xs) = do
name <- maybeM (throwResumable NoNameError) n
name <- maybeM (throwEvalError NoNameError) n
letrec' name $ \addr ->
box =<< makeNamespace name addr Nothing (void $ go (x:xs))
-- The last name creates a closure over the namespace body.
go [n] = do
name <- maybeM (throwResumable NoNameError) n
name <- maybeM (throwEvalError NoNameError) n
letrec' name $ \addr ->
box =<< makeNamespace name addr Nothing (void $ subtermAddress namespaceBody)
-- The absence of names implies global scope, cf http://php.net/manual/en/language.namespaces.definitionmultiple.php

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

@ -3,6 +3,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} -- FIXME
module Language.Python.Syntax where
import Data.Abstract.BaseError
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.Module
@ -66,7 +67,8 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (T.unpack prefix) (Ju
-- `parent/three/__init__.py` respectively.
resolvePythonModules :: ( Member (Modules address) effects
, Member (Reader ModuleInfo) effects
, Member (Resumable ResolutionError) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
)
=> QualifiedName
@ -94,7 +96,7 @@ resolvePythonModules q = do
, path <.> ".py"
]
modulePath <- resolve searchPaths
maybeM (throwResumable $ NotFoundError path searchPaths Language.Python) modulePath
maybeM (throwResolutionError $ NotFoundError path searchPaths Language.Python) modulePath
-- | Import declarations (symbols are added directly to the calling environment).

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

@ -3,6 +3,7 @@
module Language.Ruby.Syntax where
import Control.Monad (unless)
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import qualified Data.Abstract.Module as M
import Data.Abstract.Path
@ -19,7 +20,9 @@ import System.FilePath.Posix
--
-- require "json"
resolveRubyName :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
)
=> Text
-> Evaluator address value effects M.ModulePath
@ -27,18 +30,20 @@ resolveRubyName name = do
let name' = cleanNameOrPath name
let paths = [name' <.> "rb"]
modulePath <- resolve paths
maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath
maybeM (throwResolutionError $ NotFoundError name' paths Language.Ruby) modulePath
-- load "/root/src/file.rb"
resolveRubyPath :: ( Member (Modules address) effects
, Member (Resumable ResolutionError) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
)
=> Text
-> Evaluator address value effects M.ModulePath
resolveRubyPath path = do
let name' = cleanNameOrPath path
modulePath <- resolve [name']
maybeM (throwResumable $ NotFoundError name' [name'] Language.Ruby) modulePath
maybeM (throwResolutionError $ NotFoundError name' [name'] Language.Ruby) modulePath
cleanNameOrPath :: Text -> String
cleanNameOrPath = T.unpack . dropRelativePrefix . stripQuotes
@ -107,7 +112,9 @@ instance Evaluatable Load where
doLoad :: ( AbstractValue address value effects
, Member (Env address) effects
, Member (Modules address) effects
, Member (Resumable ResolutionError) effects
, Member (Reader ModuleInfo) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
)
=> Text

14
src/Language/TypeScript/Resolution.hs
View File

@ -22,6 +22,7 @@ import qualified Proto3.Wire.Decode as Decode
import qualified Proto3.Wire.Encode as Encode
import System.FilePath.Posix
import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import qualified Data.Abstract.Module as M
import Data.Abstract.Package
@ -67,7 +68,8 @@ toName = name . T.pack . unPath
resolveWithNodejsStrategy :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
)
=> ImportPath
@ -86,7 +88,8 @@ resolveWithNodejsStrategy (ImportPath path _) exts = resolveRelativePa
resolveRelativePath :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
)
=> FilePath
@ -99,7 +102,7 @@ resolveRelativePath relImportPath exts = do
trace ("attempting to resolve (relative) require/import " <> show relImportPath)
resolveModule path exts >>= either notFound (\x -> x <$ traceResolve relImportPath path)
where
notFound xs = throwResumable $ NotFoundError relImportPath xs Language.TypeScript
notFound xs = throwResolutionError $ NotFoundError relImportPath xs Language.TypeScript
-- | Resolve a non-relative TypeScript import to a known 'ModuleName' or fail.
--
@ -114,7 +117,8 @@ resolveRelativePath relImportPath exts = do
resolveNonRelativePath :: ( Member (Modules address) effects
, Member (Reader M.ModuleInfo) effects
, Member (Reader PackageInfo) effects
, Member (Resumable ResolutionError) effects
, Member (Reader Span) effects
, Member (Resumable (BaseError ResolutionError)) effects
, Member Trace effects
)
=> FilePath
@ -133,7 +137,7 @@ resolveNonRelativePath name exts = do
Left xs | parentDir <- takeDirectory path , root /= parentDir -> go root parentDir (searched <> xs)
| otherwise -> notFound (searched <> xs)
Right m -> m <$ traceResolve name m
notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript
notFound xs = throwResolutionError $ NotFoundError name xs Language.TypeScript
-- | Resolve a module name to a ModulePath.
resolveModule :: ( Member (Modules address) effects

2
src/Semantic/CLI.hs
View File

@ -102,7 +102,7 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g
<$> graphType
<*> switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module")
<*> serializer
<*> (readProjectFromPaths <|> readProjectRecursively)
<*> (readProjectRecursively <|> readProjectFromPaths)
graphType = flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)")
<|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph")
serializer = flag (Task.serialize (DOT Graph.style)) (Task.serialize (DOT Graph.style)) (long "dot" <> help "Output in DOT graph format (default)")

100
src/Semantic/Graph.hs
View File

@ -30,6 +30,7 @@ import Analysis.Abstract.Collecting
import Analysis.Abstract.Graph as Graph
import Control.Abstract
import Data.Abstract.Address
import Data.Abstract.BaseError (BaseError(..))
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import qualified Data.Abstract.ModuleTable as ModuleTable
@ -195,13 +196,13 @@ newtype ImportGraphEff address outerEffects a = ImportGraphEff
': Modules address
': Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))
': State (Graph ModuleInfo)
': Resumable (ValueError address (ImportGraphEff address outerEffects))
': Resumable (AddressError address (Value address (ImportGraphEff address outerEffects)))
': Resumable ResolutionError
': Resumable EvalError
': Resumable (EnvironmentError address)
': Resumable (Unspecialized (Value address (ImportGraphEff address outerEffects)))
': Resumable (LoadError address)
': Resumable (BaseError (ValueError address (ImportGraphEff address outerEffects)))
': Resumable (BaseError (AddressError address (Value address (ImportGraphEff address outerEffects))))
': Resumable (BaseError ResolutionError)
': Resumable (BaseError EvalError)
': Resumable (BaseError (EnvironmentError address))
': Resumable (BaseError (UnspecializedError (Value address (ImportGraphEff address outerEffects))))
': Resumable (BaseError (LoadError address))
': Fresh
': State (Heap address Latest (Value address (ImportGraphEff address outerEffects)))
': outerEffects
@ -242,16 +243,37 @@ withTermSpans :: ( HasField fields Span
-> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
withTermSpans recur term = withCurrentSpan (getField (termFAnnotation term)) (recur term)
resumingResolutionError :: (Applicative (m effects), Effectful m, Member Trace effects, Effects effects) => m (Resumable ResolutionError ': effects) a -> m effects a
resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionError: " <> prettyShow err) *> case err of
resumingResolutionError :: ( Applicative (m effects)
, Effectful m
, Member Trace effects
, Effects effects
)
=> m (Resumable (BaseError ResolutionError) ': effects) a
-> m effects a
resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of
NotFoundError nameToResolve _ _ -> pure nameToResolve
GoImportError pathToResolve -> pure [pathToResolve])
resumingLoadError :: (AbstractHole address, Effectful (m address value), Effects effects, Functor (m address value effects), Member Trace effects) => m address value (Resumable (LoadError address) ': effects) a -> m address value effects a
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> (lowerBound, hole))
resumingLoadError :: ( Applicative (m address value effects)
, AbstractHole address
, Effectful (m address value)
, Effects effects
, Member Trace effects
)
=> m address value (Resumable (BaseError (LoadError address)) ': effects) a
-> m address value effects a
resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of
ModuleNotFoundError _ -> pure (lowerBound, hole))
resumingEvalError :: (Applicative (m effects), Effectful m, Effects effects, Member Fresh effects, Member Trace effects) => m (Resumable EvalError ': effects) a -> m effects a
resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError:" <> prettyShow err) *> case err of
resumingEvalError :: ( Applicative (m effects)
, Effectful m
, Effects effects
, Member Fresh effects
, Member Trace effects
)
=> m (Resumable (BaseError EvalError) ': effects) a
-> m effects a
resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of
DefaultExportError{} -> pure ()
ExportError{} -> pure ()
IntegerFormatError{} -> pure 0
@ -259,16 +281,39 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError:" <> prettyShow
RationalFormatError{} -> pure 0
NoNameError -> gensym)
resumingUnspecialized :: (AbstractHole value, Effectful (m value), Effects effects, Functor (m value effects), Member Trace effects) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects a
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized: " <> prettyShow err) $> hole)
resumingUnspecialized :: ( Applicative (m value effects)
, AbstractHole value
, Effectful (m value)
, Effects effects
, Member Trace effects)
=> m value (Resumable (BaseError (UnspecializedError value)) ': effects) a
-> m value effects a
resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of
UnspecializedError _ -> pure hole)
resumingAddressError :: (AbstractHole value, Applicative (m address value effects), Effectful (m address value), Effects effects, Lower (Cell address value), Member Trace effects, Show address) => m address value (Resumable (AddressError address value) ': effects) a -> m address value effects a
resumingAddressError = runAddressErrorWith $ \ err -> trace ("AddressError: " <> prettyShow err) *> case err of
resumingAddressError :: ( AbstractHole value
, Applicative (m address value effects)
, Effectful (m address value)
, Effects effects
, Lower (Cell address value)
, Member Trace effects
, Show address
)
=> m address value (Resumable (BaseError (AddressError address value)) ': effects) a
-> m address value effects a
resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of
UnallocatedAddress _ -> pure lowerBound
UninitializedAddress _ -> pure hole
resumingValueError :: (Applicative (m address (Value address body) effects), Effectful (m address (Value address body)), Effects effects, Member Trace effects, Show address) => m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects a
resumingValueError = runValueErrorWith (\ err -> trace ("ValueError: " <> prettyShow err) *> case err of
resumingValueError :: ( Applicative (m address (Value address body) effects)
, Effectful (m address (Value address body))
, Effects effects
, Member Trace effects
, Show address
)
=> m address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
-> m address (Value address body) effects a
resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of
CallError val -> pure val
StringError val -> pure (pack (prettyShow val))
BoolError{} -> pure True
@ -283,19 +328,28 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError: " <> pretty
KeyValueError{} -> pure (hole, hole)
ArithmeticError{} -> pure hole)
resumingEnvironmentError :: (Applicative (m (Hole (Maybe Name) address) value effects), Effectful (m (Hole (Maybe Name) address) value), Effects effects) => m (Hole (Maybe Name) address) value (Resumable (EnvironmentError (Hole (Maybe Name) address)) ': effects) a -> m (Hole (Maybe Name) address) value effects a
resumingEnvironmentError = runResumableWith (\ (FreeVariable name) -> pure (Partial (Just name)))
resumingEnvironmentError :: ( Monad (m (Hole (Maybe Name) address) value effects)
, Effectful (m (Hole (Maybe Name) address) value)
, Effects effects
, Member Trace effects
)
=> m (Hole (Maybe Name) address) value (Resumable (BaseError (EnvironmentError (Hole (Maybe Name) address))) ': effects) a
-> m (Hole (Maybe Name) address) value effects a
resumingEnvironmentError = runResumableWith (\ baseError -> traceError "EnvironmentError" baseError >> (\ (FreeVariable name) -> pure (Partial (Just name))) (baseErrorException baseError))
resumingTypeError :: ( Alternative (m address Type (State TypeMap ': effects))
, Effects effects
, Effectful (m address Type)
, Member Trace effects
)
=> m address Type (Resumable TypeError ': State TypeMap ': effects) a
=> m address Type (Resumable (BaseError TypeError) ': State TypeMap ': effects) a
-> m address Type effects a
resumingTypeError = runTypesWith (\err -> trace ("TypeError: " <> prettyShow err) *> case err of
resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseError *> case baseErrorException baseError of
UnificationError l r -> pure l <|> pure r
InfiniteType _ r -> pure r)
prettyShow :: Show a => a -> String
prettyShow = hscolour TTY defaultColourPrefs False False "" False . ppShow
traceError :: (Member Trace effects, Effectful m, Show (exc resume)) => String -> BaseError exc resume -> m effects ()
traceError prefix baseError = trace $ prefix <> ": " <> prettyShow baseError

15
src/Semantic/Util.hs
View File

@ -10,6 +10,7 @@ import Control.Abstract
import Control.Exception (displayException)
import Control.Monad.Effect.Trace (runPrintingTrace)
import Data.Abstract.Address
import Data.Abstract.BaseError (BaseError(..))
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import qualified Data.Abstract.ModuleTable as ModuleTable
@ -63,13 +64,13 @@ newtype UtilEff a = UtilEff
, Reader (ModuleTable (NonEmpty (Module (ModuleResult Precise))))
, Reader Span
, Reader PackageInfo
, Resumable (ValueError Precise UtilEff)
, Resumable (AddressError Precise (Value Precise UtilEff))
, Resumable ResolutionError
, Resumable EvalError
, Resumable (EnvironmentError Precise)
, Resumable (Unspecialized (Value Precise UtilEff))
, Resumable (LoadError Precise)
, Resumable (BaseError (ValueError Precise UtilEff))
, Resumable (BaseError (AddressError Precise (Value Precise UtilEff)))
, Resumable (BaseError ResolutionError)
, Resumable (BaseError EvalError)
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (UnspecializedError (Value Precise UtilEff)))
, Resumable (BaseError (LoadError Precise))
, Trace
, Fresh
, State (Heap Precise Latest (Value Precise UtilEff))

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

@ -36,7 +36,7 @@ spec config = parallel $ do
it "evaluates load with wrapper" $ do
(_, (_, res)) <- evaluate ["load-wrap.rb", "foo.rb"]
res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
res `shouldBe` Left (SomeExc (inject @(BaseError (EnvironmentError Precise)) (BaseError (ModuleInfo "load-wrap.rb") emptySpan (FreeVariable "foo"))))
it "evaluates subclass" $ do
(_, (heap, res)) <- evaluate ["subclass.rb"]

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

@ -38,7 +38,7 @@ spec config = parallel $ do
it "fails exporting symbols not defined in the module" $ do
(_, (_, 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 @(BaseError EvalError) (BaseError (ModuleInfo "foo.ts") emptySpan (ExportError "foo.ts" (name "pip")))))
it "evaluates early return statements" $ do
(_, (heap, res)) <- evaluate ["early-return.ts"]

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

@ -5,6 +5,7 @@ module Control.Abstract.Evaluator.Spec
) where
import Control.Abstract
import Data.Abstract.BaseError
import Data.Abstract.Module
import qualified Data.Abstract.Number as Number
import Data.Abstract.Package
@ -36,6 +37,7 @@ evaluate
. runFresh 0
. runReader (PackageInfo (name "test") mempty)
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
. runReader (lowerBound @Span)
. fmap reassociate
. runValueError
. runEnvironmentError
@ -59,9 +61,10 @@ newtype SpecEff a = SpecEff
, Env Precise
, Allocator Precise Val
, Deref Precise Val
, Resumable (AddressError Precise Val)
, Resumable (EnvironmentError Precise)
, Resumable (ValueError Precise SpecEff)
, Resumable (BaseError (AddressError Precise Val))
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (ValueError Precise SpecEff))
, Reader Span
, Reader ModuleInfo
, Reader PackageInfo
, Fresh

30
test/SpecHelpers.hs
View File

@ -96,25 +96,25 @@ readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap file paths in
runBothWith IO.readFilePair paths'
type TestEvaluatingEffects = '[ Resumable (ValueError Precise UtilEff)
, Resumable (AddressError Precise Val)
, Resumable ResolutionError
, Resumable EvalError
, Resumable (EnvironmentError Precise)
, Resumable (Unspecialized Val)
, Resumable (LoadError Precise)
type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise UtilEff))
, Resumable (BaseError (AddressError Precise Val))
, Resumable (BaseError ResolutionError)
, Resumable (BaseError EvalError)
, Resumable (BaseError (EnvironmentError Precise))
, Resumable (BaseError (UnspecializedError Val))
, Resumable (BaseError (LoadError Precise))
, Trace
, Fresh
, State (Heap Precise Latest Val)
, Lift IO
]
type TestEvaluatingErrors = '[ ValueError Precise UtilEff
, AddressError Precise Val
, ResolutionError
, EvalError
, EnvironmentError Precise
, Unspecialized Val
, LoadError Precise
type TestEvaluatingErrors = '[ BaseError (ValueError Precise UtilEff)
, BaseError (AddressError Precise Val)
, BaseError ResolutionError
, BaseError EvalError
, BaseError (EnvironmentError Precise)
, BaseError (UnspecializedError Val)
, BaseError (LoadError Precise)
]
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (ModuleResult Precise))))
-> IO
@ -157,6 +157,8 @@ namespaceScope heap ns@(Namespace _ _ _)
. runFresh 0
. runAddressError
. runState heap
. runReader (lowerBound @Span)
. runReader (ModuleInfo "SpecHelper.hs")
. runDeref
$ materializeEnvironment ns