mirror of
https://github.com/github/semantic.git
synced 2024-11-24 08:54:07 +03:00
Resume using a first-order definition of functions.
This commit is contained in:
Rob Rix
parent
98b1b1e16b
commit
c6769d2e01
@ -75,7 +75,7 @@ cachingTerms recur0 recur term = do
|
||||
values <- consultOracle c
|
||||
cachingConfiguration c values (recur0 recur term)
|
||||
|
||||
convergingModules :: ( AbstractValue address value effects
|
||||
convergingModules :: ( AbstractValue term address value effects
|
||||
, Effects effects
|
||||
, Eq value
|
||||
, Member (Env address) effects
|
||||
|
||||
@ -75,7 +75,7 @@ cachingTerms recur0 recur term = do
|
||||
pairs <- consultOracle c
|
||||
cachingConfiguration c pairs (recur0 recur term)
|
||||
|
||||
convergingModules :: ( AbstractValue address value effects
|
||||
convergingModules :: ( AbstractValue term address value effects
|
||||
, Cacheable term address value
|
||||
, Member Fresh effects
|
||||
, Member NonDet effects
|
||||
|
||||
@ -68,7 +68,7 @@ graphingTerms :: ( Member (Reader ModuleInfo) effects
|
||||
, Member (State (Graph ControlFlowVertex)) effects
|
||||
, Member (State (Map (Hole context (Located address)) ControlFlowVertex)) effects
|
||||
, Member (Resumable (BaseError (EnvironmentError (Hole context (Located address))))) effects
|
||||
, AbstractValue (Hole context (Located address)) value effects
|
||||
, AbstractValue term (Hole context (Located address)) value effects
|
||||
, Member (Reader ControlFlowVertex) effects
|
||||
, HasField fields Span
|
||||
, VertexDeclaration syntax
|
||||
|
||||
@ -3,21 +3,15 @@ module Control.Abstract.Primitive
|
||||
( define
|
||||
, defineClass
|
||||
, defineNamespace
|
||||
, builtInPrint
|
||||
, lambda
|
||||
, Lambda(..)
|
||||
) where
|
||||
|
||||
import Data.Abstract.Environment
|
||||
import Control.Abstract.Context
|
||||
import Control.Abstract.Environment
|
||||
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
|
||||
|
||||
define :: ( HasCallStack
|
||||
@ -37,7 +31,7 @@ define name def = withCurrentCallStack callStack $ do
|
||||
def >>= assign addr
|
||||
bind name addr
|
||||
|
||||
defineClass :: ( AbstractValue address value effects
|
||||
defineClass :: ( AbstractValue term address value effects
|
||||
, HasCallStack
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref value) effects
|
||||
@ -55,7 +49,7 @@ defineClass name superclasses body = define name $ do
|
||||
binds <- Env.head <$> locally (body >> getEnv)
|
||||
klass name superclasses binds
|
||||
|
||||
defineNamespace :: ( AbstractValue address value effects
|
||||
defineNamespace :: ( AbstractValue term address value effects
|
||||
, HasCallStack
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref value) effects
|
||||
@ -71,49 +65,3 @@ defineNamespace :: ( AbstractValue address value effects
|
||||
defineNamespace name scope = define name $ do
|
||||
binds <- Env.head <$> locally (scope >> getEnv)
|
||||
namespace name Nothing binds
|
||||
|
||||
-- | Construct a function from a Haskell function taking 'Name's as arguments.
|
||||
--
|
||||
-- The constructed function will have the same arity as the Haskell function. Nullary functions are constructed by providing an evaluator producing an address. Note that the constructed function must not contain free variables as they will not be captured by the closure, and/or will be garbage collected.
|
||||
lambda :: ( HasCallStack
|
||||
, Lambda term address value effects fn
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
)
|
||||
=> fn
|
||||
-> Evaluator term address value effects value
|
||||
lambda body = withCurrentCallStack callStack (lambda' [] body)
|
||||
|
||||
-- | A class of types forming the body of 'lambda's. Note that there should in general only be two cases: a recursive case of functions taking 'Name's as parameters, and a base case of an 'Evaluator'.
|
||||
class Lambda term address value effects ty | ty -> term, ty -> address, ty -> value, ty -> effects where
|
||||
lambda' :: [Name]
|
||||
-> ty
|
||||
-> Evaluator term address value effects value
|
||||
|
||||
instance (Member Fresh effects, Lambda term address value effects ret) => Lambda term address value effects (Name -> ret) where
|
||||
lambda' vars body = do
|
||||
var <- gensym
|
||||
lambda' (var : vars) (body var)
|
||||
{-# INLINE lambda' #-}
|
||||
|
||||
instance Member (Function address value) effects => Lambda term address value effects (Evaluator term address value effects address) where
|
||||
lambda' vars = function Nothing vars lowerBound
|
||||
{-# INLINE lambda' #-}
|
||||
|
||||
builtInPrint :: ( AbstractValue address value effects
|
||||
, HasCallStack
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref value) effects
|
||||
, Member (Env address) effects
|
||||
, Member Fresh effects
|
||||
, Member (Function address value) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (AddressError address value))) effects
|
||||
, Member (Resumable (BaseError (EnvironmentError address))) effects
|
||||
, Member (State (Heap address value)) effects
|
||||
, Member Trace effects
|
||||
, Ord address
|
||||
)
|
||||
=> Evaluator term address value effects value
|
||||
builtInPrint = lambda (\ v -> variable v >>= deref >>= asString >>= trace . unpack >> box unit)
|
||||
|
||||
@ -5,43 +5,41 @@ module Control.Abstract.PythonPackage
|
||||
import Control.Abstract.Evaluator (LoopControl, Return)
|
||||
import Control.Abstract.Heap (Allocator, Deref, deref)
|
||||
import Control.Abstract.Value
|
||||
import Control.Monad.Effect (Effectful (..))
|
||||
import qualified Control.Monad.Effect as Eff
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Name (name)
|
||||
import Data.Abstract.Path (stripQuotes)
|
||||
import Data.Abstract.Value.Concrete (Value (..), ValueError (..))
|
||||
import Data.Coerce
|
||||
import qualified Data.Map as Map
|
||||
import Prologue
|
||||
|
||||
data Strategy = Unknown | Packages [Text] | FindPackages [Text]
|
||||
deriving (Show, Eq)
|
||||
|
||||
runPythonPackaging :: forall effects term address body a. (
|
||||
runPythonPackaging :: forall effects term address a. (
|
||||
Eff.PureEffects effects
|
||||
, Ord address
|
||||
, Show address
|
||||
, Show term
|
||||
, Member Trace effects
|
||||
, Member (Boolean (Value address body)) effects
|
||||
, Member (State (Heap address (Value address body))) effects
|
||||
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
|
||||
, Member (Resumable (BaseError (ValueError address body))) effects
|
||||
, Member (Boolean (Value address term)) effects
|
||||
, Member (State (Heap address (Value address term))) effects
|
||||
, Member (Resumable (BaseError (AddressError address (Value address term)))) effects
|
||||
, Member (Resumable (BaseError (ValueError address term))) effects
|
||||
, Member Fresh effects
|
||||
, Coercible body (Eff.Eff effects)
|
||||
, Member (State Strategy) effects
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref (Value address body)) effects
|
||||
, Member (Deref (Value address term)) effects
|
||||
, Member (Env address) effects
|
||||
, Member (Eff.Exc (LoopControl address)) effects
|
||||
, Member (Eff.Exc (Return address)) effects
|
||||
, Member (Eff.Reader ModuleInfo) effects
|
||||
, Member (Eff.Reader PackageInfo) effects
|
||||
, Member (Eff.Reader Span) effects
|
||||
, Member (Function address (Value address body)) effects)
|
||||
=> Evaluator term address (Value address body) effects a
|
||||
-> Evaluator term address (Value address body) effects a
|
||||
runPythonPackaging = Eff.interpose @(Function address (Value address body)) $ \case
|
||||
, Member (Function term address (Value address term)) effects)
|
||||
=> Evaluator term address (Value address term) effects a
|
||||
-> Evaluator term address (Value address term) effects a
|
||||
runPythonPackaging = Eff.interpose @(Function term address (Value address term)) $ \case
|
||||
Call callName super params -> do
|
||||
case callName of
|
||||
Closure _ _ name' paramNames _ _ -> do
|
||||
@ -63,4 +61,4 @@ runPythonPackaging = Eff.interpose @(Function address (Value address body)) $ \c
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
call callName super params
|
||||
Function name params vars body -> function name params vars (raiseEff body)
|
||||
Function name params body -> function name params body
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, Rank2Types #-}
|
||||
{-# LANGUAGE GADTs, KindSignatures, Rank2Types #-}
|
||||
module Control.Abstract.Value
|
||||
( AbstractValue(..)
|
||||
, AbstractIntro(..)
|
||||
@ -28,8 +28,8 @@ module Control.Abstract.Value
|
||||
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.Environment as Env
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.Name
|
||||
import Data.Abstract.Number as Number
|
||||
@ -62,19 +62,23 @@ data Comparator
|
||||
--
|
||||
-- In the concrete domain, introductions & eliminations respectively construct & pattern match against values, while in abstract domains they respectively construct & project finite sets of discrete observations of abstract values. For example, an abstract domain modelling integers as a sign (-, 0, or +) would introduce abstract values by mapping integers to their sign and eliminate them by mapping signs back to some canonical integer, e.g. - -> -1, 0 -> 0, + -> 1.
|
||||
|
||||
function :: Member (Function address value) effects => Maybe Name -> [Name] -> Set Name -> Evaluator term address value effects address -> Evaluator term address value effects value
|
||||
function name params fvs (Evaluator body) = send (Function name params fvs body)
|
||||
function :: Member (Function term address value) effects => Maybe Name -> [Name] -> term -> Evaluator term address value effects value
|
||||
function name params body = sendFunction (Function name params body)
|
||||
|
||||
call :: Member (Function address value) effects => value -> address -> [address] -> Evaluator term address value effects address
|
||||
call fn self args = send (Call fn self args)
|
||||
call :: Member (Function term address value) effects => value -> address -> [address] -> Evaluator term address value effects address
|
||||
call fn self args = sendFunction (Call fn self args)
|
||||
|
||||
data Function address value m result where
|
||||
Function :: Maybe Name -> [Name] -> Set Name -> m address -> Function address value m value
|
||||
Call :: value -> address -> [address] -> Function address value m address
|
||||
sendFunction :: Member (Function term address value) effects => Function term address value (Eff effects) a -> Evaluator term address value effects a
|
||||
sendFunction = send
|
||||
|
||||
instance PureEffect (Function address value) where
|
||||
handle handler (Request (Function name params fvs body) k) = Request (Function name params fvs (handler body)) (handler . k)
|
||||
handle handler (Request (Call fn self addrs) k) = Request (Call fn self addrs) (handler . k)
|
||||
data Function term address value (m :: * -> *) result where
|
||||
Function :: Maybe Name -> [Name] -> term -> Function term address value m value
|
||||
Call :: value -> address -> [address] -> Function term address value m address
|
||||
|
||||
instance PureEffect (Function term address value)
|
||||
instance Effect (Function term address value) where
|
||||
handleState state handler (Request (Function name params body) k) = Request (Function name params body) (handler . (<$ state) . k)
|
||||
handleState state handler (Request (Call fn self addrs) k) = Request (Call fn self addrs) (handler . (<$ state) . k)
|
||||
|
||||
-- | Construct a boolean value in the abstract domain.
|
||||
boolean :: Member (Boolean value) effects => Bool -> Evaluator term address value effects value
|
||||
@ -139,7 +143,7 @@ class Show value => AbstractIntro value where
|
||||
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
|
||||
--
|
||||
-- This allows us to abstract the choice of whether to evaluate under binders for different value types.
|
||||
class AbstractIntro value => AbstractValue address value effects where
|
||||
class AbstractIntro value => AbstractValue term address value effects where
|
||||
-- | Cast numbers to integers
|
||||
castToInteger :: value -> Evaluator term address value effects value
|
||||
|
||||
@ -211,7 +215,7 @@ class AbstractIntro value => AbstractValue address value effects where
|
||||
|
||||
|
||||
-- | C-style for loops.
|
||||
forLoop :: ( AbstractValue address value effects
|
||||
forLoop :: ( AbstractValue term address value effects
|
||||
, Member (Boolean value) effects
|
||||
, Member (Env address) effects
|
||||
)
|
||||
@ -224,7 +228,7 @@ forLoop initial cond step body =
|
||||
locally (initial *> while cond (body *> step))
|
||||
|
||||
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
|
||||
while :: (AbstractValue address value effects, Member (Boolean value) effects)
|
||||
while :: (AbstractValue term address value effects, Member (Boolean value) effects)
|
||||
=> Evaluator term address value effects value
|
||||
-> Evaluator term address value effects value
|
||||
-> Evaluator term address value effects value
|
||||
@ -233,7 +237,7 @@ while cond body = loop $ \ continue -> do
|
||||
ifthenelse this (body *> continue) (pure unit)
|
||||
|
||||
-- | Do-while loop, built on top of while.
|
||||
doWhile :: (AbstractValue address value effects, Member (Boolean value) effects)
|
||||
doWhile :: (AbstractValue term address value effects, Member (Boolean value) effects)
|
||||
=> Evaluator term address value effects value
|
||||
-> Evaluator term address value effects value
|
||||
-> Evaluator term address value effects value
|
||||
@ -241,7 +245,7 @@ doWhile body cond = loop $ \ continue -> body *> do
|
||||
this <- cond
|
||||
ifthenelse this continue (pure unit)
|
||||
|
||||
makeNamespace :: ( AbstractValue address value effects
|
||||
makeNamespace :: ( AbstractValue term address value effects
|
||||
, Member (Deref value) effects
|
||||
, Member (Env address) effects
|
||||
, Member (State (Heap address value)) effects
|
||||
@ -259,7 +263,7 @@ makeNamespace name addr super body = do
|
||||
|
||||
|
||||
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
|
||||
evaluateInScopedEnv :: ( AbstractValue address value effects
|
||||
evaluateInScopedEnv :: ( AbstractValue term address value effects
|
||||
, Member (Env address) effects
|
||||
)
|
||||
=> address
|
||||
@ -272,7 +276,7 @@ evaluateInScopedEnv receiver term = do
|
||||
|
||||
|
||||
-- | Evaluates a 'Value' returning the referenced value
|
||||
value :: ( AbstractValue address value effects
|
||||
value :: ( AbstractValue term address value effects
|
||||
, Member (Deref value) effects
|
||||
, Member (Env address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
@ -287,7 +291,7 @@ value :: ( AbstractValue address value effects
|
||||
value = deref <=< address
|
||||
|
||||
-- | Evaluates a 'Subterm' to its rval
|
||||
subtermValue :: ( AbstractValue address value effects
|
||||
subtermValue :: ( AbstractValue term address value effects
|
||||
, Member (Deref value) effects
|
||||
, Member (Env address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
@ -302,7 +306,7 @@ subtermValue :: ( AbstractValue address value effects
|
||||
subtermValue = value <=< subtermRef
|
||||
|
||||
-- | Returns the address of a value referenced by a 'ValueRef'
|
||||
address :: ( AbstractValue address value effects
|
||||
address :: ( AbstractValue term address value effects
|
||||
, Member (Env address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
@ -315,7 +319,7 @@ address (LvalMember ptr prop) = evaluateInScopedEnv ptr (variable prop)
|
||||
address (Rval addr) = pure addr
|
||||
|
||||
-- | Evaluates a 'Subterm' to the address of its rval
|
||||
subtermAddress :: ( AbstractValue address value effects
|
||||
subtermAddress :: ( AbstractValue term address value effects
|
||||
, Member (Env address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
|
||||
@ -49,7 +49,7 @@ import Prologue
|
||||
|
||||
-- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
|
||||
class (Show1 constr, Foldable constr) => Evaluatable constr where
|
||||
eval :: ( AbstractValue address value effects
|
||||
eval :: ( AbstractValue term address value effects
|
||||
, Declarations term
|
||||
, FreeVariables term
|
||||
, Member (Allocator address) effects
|
||||
@ -60,7 +60,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where
|
||||
, Member (Exc (LoopControl address)) effects
|
||||
, Member (Exc (Return address)) effects
|
||||
, Member Fresh effects
|
||||
, Member (Function address value) effects
|
||||
, Member (Function term address value) effects
|
||||
, Member (Modules address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
@ -93,12 +93,12 @@ type ModuleEffects address value rest
|
||||
': Reader ModuleInfo
|
||||
': rest
|
||||
|
||||
type ValueEffects address value rest
|
||||
= Function address value
|
||||
type ValueEffects term address value rest
|
||||
= Function term address value
|
||||
': Boolean value
|
||||
': rest
|
||||
|
||||
evaluate :: ( AbstractValue address value valueEffects
|
||||
evaluate :: ( AbstractValue term address value valueEffects
|
||||
, Declarations term
|
||||
, Effects effects
|
||||
, Evaluatable (Base term)
|
||||
@ -121,17 +121,17 @@ evaluate :: ( AbstractValue address value valueEffects
|
||||
, Ord address
|
||||
, Recursive term
|
||||
, moduleEffects ~ ModuleEffects address value effects
|
||||
, valueEffects ~ ValueEffects address value moduleEffects
|
||||
, valueEffects ~ ValueEffects term address value moduleEffects
|
||||
)
|
||||
=> proxy lang
|
||||
-> Open (Module term -> Evaluator term address value moduleEffects address)
|
||||
-> Open (Open (term -> Evaluator term address value valueEffects (ValueRef address)))
|
||||
-> (forall x . Evaluator term address value (Deref value ': Allocator address ': Reader ModuleInfo ': effects) x -> Evaluator term address value (Reader ModuleInfo ': effects) x)
|
||||
-> (forall x . Evaluator term address value valueEffects x -> Evaluator term address value moduleEffects x)
|
||||
-> (forall x . (term -> Evaluator term address value valueEffects address) -> Evaluator term address value valueEffects x -> Evaluator term address value moduleEffects x)
|
||||
-> [Module term]
|
||||
-> Evaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address))))
|
||||
evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
|
||||
(_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue $ do
|
||||
(_, (preludeBinds, _)) <- runInModule lowerBound moduleInfoFromCallStack . runValue evalTerm $ do
|
||||
definePrelude lang
|
||||
box unit
|
||||
foldr (run preludeBinds) ask modules
|
||||
@ -143,10 +143,12 @@ evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do
|
||||
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
|
||||
local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
|
||||
|
||||
evalModuleBody term = coerce runValue (do
|
||||
result <- fix (analyzeTerm ((. project) . eval)) term >>= address
|
||||
evalModuleBody term = runValue evalTerm (do
|
||||
result <- evalTerm term
|
||||
result <$ postlude lang)
|
||||
|
||||
evalTerm = fix (analyzeTerm ((. project) . eval)) >=> address
|
||||
|
||||
runInModule preludeBinds info
|
||||
= runReader info
|
||||
. runAllocDeref
|
||||
@ -163,13 +165,13 @@ traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
|
||||
-- Preludes
|
||||
|
||||
class HasPrelude (language :: Language) where
|
||||
definePrelude :: ( AbstractValue address value effects
|
||||
definePrelude :: ( AbstractValue term address value effects
|
||||
, HasCallStack
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref value) effects
|
||||
, Member (Env address) effects
|
||||
, Member Fresh effects
|
||||
, Member (Function address value) effects
|
||||
, Member (Function term address value) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (AddressError address value))) effects
|
||||
@ -188,30 +190,30 @@ instance HasPrelude 'Java
|
||||
instance HasPrelude 'PHP
|
||||
|
||||
instance HasPrelude 'Python where
|
||||
definePrelude _ =
|
||||
define (name "print") builtInPrint
|
||||
-- definePrelude _ =
|
||||
-- define (name "print") (builtIn Print)
|
||||
|
||||
instance HasPrelude 'Ruby where
|
||||
definePrelude _ = do
|
||||
define (name "puts") builtInPrint
|
||||
|
||||
defineClass (name "Object") [] $ do
|
||||
define (name "inspect") (lambda (box (string "<object>")))
|
||||
-- definePrelude _ = do
|
||||
-- define (name "puts") (builtIn Print)
|
||||
--
|
||||
-- defineClass (name "Object") [] $ do
|
||||
-- define (name "inspect") (builtIn (Constant (string "<object>")))
|
||||
|
||||
instance HasPrelude 'TypeScript where
|
||||
definePrelude _ =
|
||||
defineNamespace (name "console") $ do
|
||||
define (name "log") builtInPrint
|
||||
-- definePrelude _ =
|
||||
-- defineNamespace (name "console") $ do
|
||||
-- define (name "log") (builtIn Print)
|
||||
|
||||
instance HasPrelude 'JavaScript where
|
||||
definePrelude _ = do
|
||||
defineNamespace (name "console") $ do
|
||||
define (name "log") builtInPrint
|
||||
-- definePrelude _ = do
|
||||
-- defineNamespace (name "console") $ do
|
||||
-- define (name "log") (builtIn Print)
|
||||
|
||||
-- Postludes
|
||||
|
||||
class HasPostlude (language :: Language) where
|
||||
postlude :: ( AbstractValue address value effects
|
||||
postlude :: ( AbstractValue term address value effects
|
||||
, HasCallStack
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref value) effects
|
||||
|
||||
@ -26,15 +26,16 @@ runFunction :: ( Member (Allocator address) effects
|
||||
, Ord address
|
||||
, PureEffects effects
|
||||
)
|
||||
=> Evaluator term address Abstract (Function address Abstract ': effects) a
|
||||
=> (term -> Evaluator term address Abstract (Abstract.Function term address Abstract ': effects) address)
|
||||
-> Evaluator term address Abstract (Function term address Abstract ': effects) a
|
||||
-> Evaluator term address Abstract effects a
|
||||
runFunction = interpret $ \case
|
||||
Function _ params _ body -> do
|
||||
runFunction eval = interpret $ \case
|
||||
Function _ params body -> do
|
||||
env <- foldr (\ name rest -> do
|
||||
addr <- alloc name
|
||||
assign addr Abstract
|
||||
Env.insert name addr <$> rest) (pure lowerBound) params
|
||||
addr <- locally (bindAll env *> catchReturn (runFunction (Evaluator body)))
|
||||
addr <- locally (bindAll env *> catchReturn (runFunction eval (eval body)))
|
||||
deref addr
|
||||
Call _ _ params -> do
|
||||
traverse_ deref params
|
||||
@ -76,7 +77,7 @@ instance ( Member (Allocator address) effects
|
||||
, Member (State (Heap address Abstract)) effects
|
||||
, Ord address
|
||||
)
|
||||
=> AbstractValue address Abstract effects where
|
||||
=> AbstractValue term address Abstract effects where
|
||||
array _ = pure Abstract
|
||||
|
||||
tuple _ = pure Abstract
|
||||
|
||||
@ -2,7 +2,6 @@
|
||||
module Data.Abstract.Value.Concrete
|
||||
( Value (..)
|
||||
, ValueError (..)
|
||||
, ClosureBody (..)
|
||||
, runFunction
|
||||
, runBoolean
|
||||
, materializeEnvironment
|
||||
@ -15,10 +14,10 @@ import Control.Abstract hiding (Boolean(..), Function(..))
|
||||
import Data.Abstract.BaseError
|
||||
import Data.Abstract.Environment (Environment, Bindings, EvalContext(..))
|
||||
import qualified Data.Abstract.Environment as Env
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Name
|
||||
import qualified Data.Abstract.Number as Number
|
||||
import Data.Bits
|
||||
import Data.Coerce
|
||||
import Data.List (genericIndex, genericLength)
|
||||
import Data.Scientific (Scientific, coefficient, normalize)
|
||||
import Data.Scientific.Exts
|
||||
@ -26,8 +25,8 @@ import qualified Data.Set as Set
|
||||
import Data.Word
|
||||
import Prologue
|
||||
|
||||
data Value address body
|
||||
= Closure PackageInfo ModuleInfo (Maybe Name) [Name] (ClosureBody address body) (Environment address)
|
||||
data Value address term
|
||||
= Closure PackageInfo ModuleInfo (Maybe Name) [Name] term (Environment address)
|
||||
| Unit
|
||||
| Boolean Bool
|
||||
| Integer (Number.Number Integer)
|
||||
@ -40,72 +39,60 @@ data Value address body
|
||||
| Array [address]
|
||||
| Class Name [address] (Bindings address)
|
||||
| Namespace Name (Maybe address) (Bindings address)
|
||||
| KVPair (Value address body) (Value address body)
|
||||
| Hash [Value address body]
|
||||
| KVPair (Value address term) (Value address term)
|
||||
| Hash [Value address term]
|
||||
| Null
|
||||
| Hole
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ClosureBody address body = ClosureBody { closureBodyId :: Int, closureBody :: body address }
|
||||
|
||||
instance Eq (ClosureBody address body) where
|
||||
(==) = (==) `on` closureBodyId
|
||||
|
||||
instance Ord (ClosureBody address body) where
|
||||
compare = compare `on` closureBodyId
|
||||
|
||||
instance Show (ClosureBody address body) where
|
||||
showsPrec d (ClosureBody i _) = showsUnaryWith showsPrec "ClosureBody" d i
|
||||
|
||||
|
||||
instance Ord address => ValueRoots address (Value address body) where
|
||||
instance Ord address => ValueRoots address (Value address term) where
|
||||
valueRoots v
|
||||
| Closure _ _ _ _ _ env <- v = Env.addresses env
|
||||
| otherwise = mempty
|
||||
|
||||
|
||||
runFunction :: ( Member (Allocator address) effects
|
||||
, Member (Deref (Value address body)) effects
|
||||
runFunction :: ( FreeVariables term
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref (Value address term)) effects
|
||||
, Member (Env address) effects
|
||||
, Member (Exc (Return address)) effects
|
||||
, Member Fresh effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
|
||||
, Member (Resumable (BaseError (ValueError address body))) effects
|
||||
, Member (State (Heap address (Value address body))) effects
|
||||
, Member (Resumable (BaseError (AddressError address (Value address term)))) effects
|
||||
, Member (Resumable (BaseError (ValueError address term))) effects
|
||||
, Member (State (Heap address (Value address term))) effects
|
||||
, Ord address
|
||||
, PureEffects effects
|
||||
)
|
||||
=> (body address -> Evaluator term address (Value address body) (Abstract.Function address (Value address body) ': effects) address)
|
||||
-> (Evaluator term address value (Abstract.Function address (Value address body) ': effects) address -> body address)
|
||||
-> Evaluator term address (Value address body) (Abstract.Function address (Value address body) ': effects) a
|
||||
-> Evaluator term address (Value address body) effects a
|
||||
runFunction toEvaluator fromEvaluator = interpret $ \case
|
||||
Abstract.Function name params fvs body -> do
|
||||
=> (term -> Evaluator term address (Value address term) (Abstract.Function term address (Value address term) ': effects) address)
|
||||
-> Evaluator term address (Value address term) (Abstract.Function term address (Value address term) ': effects) a
|
||||
-> Evaluator term address (Value address term) effects a
|
||||
runFunction eval = interpret $ \case
|
||||
Abstract.Function name params body -> do
|
||||
packageInfo <- currentPackage
|
||||
moduleInfo <- currentModule
|
||||
i <- fresh
|
||||
Closure packageInfo moduleInfo name params (ClosureBody i (fromEvaluator (Evaluator body))) <$> close (foldr Set.delete fvs params)
|
||||
Closure packageInfo moduleInfo name params body <$> close (foldr Set.delete (freeVariables body) params)
|
||||
Abstract.Call op self params -> do
|
||||
case op of
|
||||
Closure packageInfo moduleInfo _ names (ClosureBody _ body) env -> do
|
||||
Closure packageInfo moduleInfo _ names body env -> do
|
||||
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
|
||||
-- charge them to the closure's origin.
|
||||
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
|
||||
bindings <- foldr (\ (name, addr) rest -> Env.insert name addr <$> rest) (pure lowerBound) (zip names params)
|
||||
let fnCtx = EvalContext (Just self) (Env.push env)
|
||||
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction toEvaluator fromEvaluator (toEvaluator body)))
|
||||
withEvalContext fnCtx (catchReturn (bindAll bindings *> runFunction eval (eval body)))
|
||||
_ -> throwValueError (CallError op) >>= box
|
||||
|
||||
runBoolean :: ( Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (ValueError address body))) effects
|
||||
, Member (Resumable (BaseError (ValueError address term))) effects
|
||||
, PureEffects effects
|
||||
)
|
||||
=> Evaluator term address (Value address body) (Abstract.Boolean (Value address body) ': effects) a
|
||||
-> Evaluator term address (Value address body) effects a
|
||||
=> Evaluator term address (Value address term) (Abstract.Boolean (Value address term) ': effects) a
|
||||
-> Evaluator term address (Value address term) effects a
|
||||
runBoolean = interpret $ \case
|
||||
Abstract.Boolean b -> pure $! Boolean b
|
||||
Abstract.AsBool (Boolean b) -> pure b
|
||||
@ -116,10 +103,10 @@ runBoolean = interpret $ \case
|
||||
if a'' then pure a' else runBoolean (Evaluator b)
|
||||
|
||||
|
||||
instance AbstractHole (Value address body) where
|
||||
instance AbstractHole (Value address term) where
|
||||
hole = Hole
|
||||
|
||||
instance Show address => AbstractIntro (Value address body) where
|
||||
instance (Show address, Show term) => AbstractIntro (Value address term) where
|
||||
unit = Unit
|
||||
integer = Integer . Number.Integer
|
||||
string = String
|
||||
@ -133,15 +120,15 @@ instance Show address => AbstractIntro (Value address body) where
|
||||
|
||||
null = Null
|
||||
|
||||
materializeEnvironment :: ( Member (Deref (Value address body)) effects
|
||||
materializeEnvironment :: ( Member (Deref (Value address term)) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
|
||||
, Member (State (Heap address (Value address body))) effects
|
||||
, Member (Resumable (BaseError (AddressError address (Value address term)))) effects
|
||||
, Member (State (Heap address (Value address term))) effects
|
||||
, Ord address
|
||||
)
|
||||
=> Value address body
|
||||
-> Evaluator term address (Value address body) effects (Maybe (Environment address))
|
||||
=> Value address term
|
||||
-> Evaluator term address (Value address term) effects (Maybe (Environment address))
|
||||
materializeEnvironment val = do
|
||||
ancestors <- rec val
|
||||
pure (Env.Environment <$> nonEmpty ancestors)
|
||||
@ -161,10 +148,9 @@ materializeEnvironment val = do
|
||||
_ -> []
|
||||
|
||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||
instance ( Coercible body (Eff effects)
|
||||
, Member (Allocator address) effects
|
||||
, Member (Abstract.Boolean (Value address body)) effects
|
||||
, Member (Deref (Value address body)) effects
|
||||
instance ( Member (Allocator address) effects
|
||||
, Member (Abstract.Boolean (Value address term)) effects
|
||||
, Member (Deref (Value address term)) effects
|
||||
, Member (Env address) effects
|
||||
, Member (Exc (LoopControl address)) effects
|
||||
, Member (Exc (Return address)) effects
|
||||
@ -172,14 +158,15 @@ instance ( Coercible body (Eff effects)
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (ValueError address body))) effects
|
||||
, Member (Resumable (BaseError (AddressError address (Value address body)))) effects
|
||||
, Member (State (Heap address (Value address body))) effects
|
||||
, Member (Resumable (BaseError (ValueError address term))) effects
|
||||
, Member (Resumable (BaseError (AddressError address (Value address term)))) effects
|
||||
, Member (State (Heap address (Value address term))) effects
|
||||
, Member Trace effects
|
||||
, Ord address
|
||||
, Show address
|
||||
, Show term
|
||||
)
|
||||
=> AbstractValue address (Value address body) effects where
|
||||
=> AbstractValue term address (Value address term) effects where
|
||||
asPair val
|
||||
| KVPair k v <- val = pure (k, v)
|
||||
| otherwise = throwValueError $ KeyValueError val
|
||||
@ -244,13 +231,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
|
||||
specialize :: ( AbstractValue term address (Value address term) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (BaseError (ValueError address body))) effects
|
||||
, Member (Resumable (BaseError (ValueError address term))) effects
|
||||
)
|
||||
=> Either ArithException Number.SomeNumber
|
||||
-> Evaluator term address (Value address body) effects (Value address body)
|
||||
-> Evaluator term address (Value address term) effects (Value address term)
|
||||
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
|
||||
@ -269,7 +256,7 @@ instance ( Coercible body (Eff effects)
|
||||
where
|
||||
-- Explicit type signature is necessary here because we're passing all sorts of things
|
||||
-- to these comparison functions.
|
||||
go :: (AbstractValue address (Value address body) effects, Member (Abstract.Boolean (Value address body)) effects, Ord a) => a -> a -> Evaluator term address (Value address body) effects (Value address body)
|
||||
go :: (AbstractValue term address (Value address term) effects, Member (Abstract.Boolean (Value address term)) effects, Ord a) => a -> a -> Evaluator term address (Value address term) effects (Value address term)
|
||||
go l r = case comparator of
|
||||
Concrete f -> boolean (f l r)
|
||||
Generalized -> pure $ integer (orderingToInt (compare l r))
|
||||
@ -309,26 +296,26 @@ instance ( Coercible body (Eff effects)
|
||||
castToInteger i = throwValueError (NumericError i)
|
||||
|
||||
-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
|
||||
data ValueError address body resume where
|
||||
StringError :: Value address body -> ValueError address body Text
|
||||
BoolError :: Value address body -> ValueError address body Bool
|
||||
IndexError :: Value address body -> Value address body -> ValueError address body (Value address body)
|
||||
NamespaceError :: Prelude.String -> ValueError address body (Bindings address)
|
||||
CallError :: Value address body -> ValueError address body (Value address body)
|
||||
NumericError :: Value address body -> ValueError address body (Value address body)
|
||||
Numeric2Error :: Value address body -> Value address body -> ValueError address body (Value address body)
|
||||
ComparisonError :: Value address body -> Value address body -> ValueError address body (Value address body)
|
||||
BitwiseError :: Value address body -> ValueError address body (Value address body)
|
||||
Bitwise2Error :: Value address body -> Value address body -> ValueError address body (Value address body)
|
||||
KeyValueError :: Value address body -> ValueError address body (Value address body, Value address body)
|
||||
ArrayError :: Value address body -> ValueError address body [address]
|
||||
data ValueError address term resume where
|
||||
StringError :: Value address term -> ValueError address term Text
|
||||
BoolError :: Value address term -> ValueError address term Bool
|
||||
IndexError :: Value address term -> Value address term -> ValueError address term (Value address term)
|
||||
NamespaceError :: Prelude.String -> ValueError address term (Bindings address)
|
||||
CallError :: Value address term -> ValueError address term (Value address term)
|
||||
NumericError :: Value address term -> ValueError address term (Value address term)
|
||||
Numeric2Error :: Value address term -> Value address term -> ValueError address term (Value address term)
|
||||
ComparisonError :: Value address term -> Value address term -> ValueError address term (Value address term)
|
||||
BitwiseError :: Value address term -> ValueError address term (Value address term)
|
||||
Bitwise2Error :: Value address term -> Value address term -> ValueError address term (Value address term)
|
||||
KeyValueError :: Value address term -> ValueError address term (Value address term, Value address term)
|
||||
ArrayError :: Value address term -> ValueError address term [address]
|
||||
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
|
||||
ArithmeticError :: ArithException -> ValueError address body (Value address body)
|
||||
ArithmeticError :: ArithException -> ValueError address term (Value address term)
|
||||
-- Out-of-bounds error
|
||||
BoundsError :: [address] -> Prelude.Integer -> ValueError address body (Value address body)
|
||||
BoundsError :: [address] -> Prelude.Integer -> ValueError address term (Value address term)
|
||||
|
||||
|
||||
instance Eq address => Eq1 (ValueError address body) where
|
||||
instance (Eq address, Eq term) => Eq1 (ValueError address term) where
|
||||
liftEq _ (StringError a) (StringError b) = a == b
|
||||
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
|
||||
liftEq _ (CallError a) (CallError b) = a == b
|
||||
@ -342,25 +329,25 @@ instance Eq address => Eq1 (ValueError address body) where
|
||||
liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d)
|
||||
liftEq _ _ _ = False
|
||||
|
||||
deriving instance Show address => Show (ValueError address body resume)
|
||||
instance Show address => Show1 (ValueError address body) where
|
||||
deriving instance (Show address, Show term) => Show (ValueError address term resume)
|
||||
instance (Show address, Show term) => Show1 (ValueError address term) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
|
||||
runValueError :: Effects effects
|
||||
=> Evaluator term address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
|
||||
-> Evaluator term address (Value address body) effects (Either (SomeExc (BaseError (ValueError address body))) a)
|
||||
=> Evaluator term address (Value address term) (Resumable (BaseError (ValueError address term)) ': effects) a
|
||||
-> Evaluator term address (Value address term) effects (Either (SomeExc (BaseError (ValueError address term))) a)
|
||||
runValueError = runResumable
|
||||
|
||||
runValueErrorWith :: Effects effects
|
||||
=> (forall resume . BaseError (ValueError address body) resume -> Evaluator term address (Value address body) effects resume)
|
||||
-> Evaluator term address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
|
||||
-> Evaluator term address (Value address body) effects a
|
||||
=> (forall resume . BaseError (ValueError address term) resume -> Evaluator term address (Value address term) effects resume)
|
||||
-> Evaluator term address (Value address term) (Resumable (BaseError (ValueError address term)) ': effects) a
|
||||
-> Evaluator term address (Value address term) effects a
|
||||
runValueErrorWith = runResumableWith
|
||||
|
||||
throwValueError :: ( Member (Resumable (BaseError (ValueError address body))) effects
|
||||
throwValueError :: ( Member (Resumable (BaseError (ValueError address term))) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
)
|
||||
=> ValueError address body resume
|
||||
-> Evaluator term address (Value address body) effects resume
|
||||
=> ValueError address term resume
|
||||
-> Evaluator term address (Value address term) effects resume
|
||||
throwValueError = throwBaseError
|
||||
|
||||
@ -243,16 +243,17 @@ runFunction :: ( Member (Allocator address) effects
|
||||
, Ord address
|
||||
, PureEffects effects
|
||||
)
|
||||
=> Evaluator term address Type (Abstract.Function address Type ': effects) a
|
||||
=> (term -> Evaluator term address Type (Abstract.Function term address Type ': effects) address)
|
||||
-> Evaluator term address Type (Abstract.Function term address Type ': effects) a
|
||||
-> Evaluator term address Type effects a
|
||||
runFunction = interpret $ \case
|
||||
Abstract.Function _ params _ body -> do
|
||||
runFunction eval = interpret $ \case
|
||||
Abstract.Function _ params body -> do
|
||||
(env, tvars) <- foldr (\ name rest -> do
|
||||
addr <- alloc name
|
||||
tvar <- Var <$> fresh
|
||||
assign addr tvar
|
||||
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) params
|
||||
(zeroOrMoreProduct tvars :->) <$> (locally (catchReturn (bindAll env *> runFunction (Evaluator body))) >>= deref)
|
||||
(zeroOrMoreProduct tvars :->) <$> (locally (catchReturn (bindAll env *> runFunction eval (eval body))) >>= deref)
|
||||
Abstract.Call op _ params -> do
|
||||
tvar <- fresh
|
||||
paramTypes <- traverse deref params
|
||||
@ -306,7 +307,7 @@ instance ( Member (Allocator address) effects
|
||||
, Member (State TypeMap) effects
|
||||
, Ord address
|
||||
)
|
||||
=> AbstractValue address Type effects where
|
||||
=> AbstractValue term address Type effects where
|
||||
array fields = do
|
||||
var <- fresh
|
||||
fieldTypes <- traverse deref fields
|
||||
|
||||
@ -30,7 +30,7 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Evaluatable Function where
|
||||
eval eval Function{..} = do
|
||||
name <- maybeM (throwEvalError NoNameError) (declaredName functionName)
|
||||
(_, addr) <- letrec name (function (Just name) (paramNames functionParameters) (freeVariables functionBody) (eval functionBody >>= address))
|
||||
(_, addr) <- letrec name (function (Just name) (paramNames functionParameters) functionBody)
|
||||
bind name addr
|
||||
pure (Rval addr)
|
||||
where paramNames = foldMap (maybeToList . declaredName)
|
||||
@ -63,7 +63,7 @@ instance Diffable Method where
|
||||
instance Evaluatable Method where
|
||||
eval eval Method{..} = do
|
||||
name <- maybeM (throwEvalError NoNameError) (declaredName methodName)
|
||||
(_, addr) <- letrec name (function (Just name) (paramNames methodParameters) (freeVariables methodBody) (eval methodBody >>= address))
|
||||
(_, addr) <- letrec name (function (Just name) (paramNames methodParameters) methodBody)
|
||||
bind name addr
|
||||
pure (Rval addr)
|
||||
where paramNames = foldMap (maybeToList . declaredName)
|
||||
|
||||
@ -51,7 +51,7 @@ resolvePHPName n = do
|
||||
where name = toName n
|
||||
toName = T.unpack . dropRelativePrefix . stripQuotes
|
||||
|
||||
include :: ( AbstractValue address value effects
|
||||
include :: ( AbstractValue term address value effects
|
||||
, Member (Deref value) effects
|
||||
, Member (Env address) effects
|
||||
, Member (Modules address) effects
|
||||
|
||||
@ -155,7 +155,7 @@ instance Evaluatable Import where
|
||||
|
||||
|
||||
-- Evaluate a qualified import
|
||||
evalQualifiedImport :: ( AbstractValue address value effects
|
||||
evalQualifiedImport :: ( AbstractValue term address value effects
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref value) effects
|
||||
, Member (Env address) effects
|
||||
|
||||
@ -163,7 +163,7 @@ typescriptExtensions = ["ts", "tsx", "d.ts"]
|
||||
javascriptExtensions :: [String]
|
||||
javascriptExtensions = ["js"]
|
||||
|
||||
evalRequire :: ( AbstractValue address value effects
|
||||
evalRequire :: ( AbstractValue term address value effects
|
||||
, Member (Allocator address) effects
|
||||
, Member (Deref value) effects
|
||||
, Member (Env address) effects
|
||||
|
||||
@ -8,8 +8,8 @@ module Semantic.Graph
|
||||
, GraphType(..)
|
||||
, Graph
|
||||
, ControlFlowVertex
|
||||
, ConcreteEff(..)
|
||||
, style
|
||||
, runHeap
|
||||
, parsePackage
|
||||
, parsePythonPackage
|
||||
, withTermSpans
|
||||
@ -45,7 +45,6 @@ import Data.Abstract.Value.Concrete as Concrete
|
||||
(Value, ValueError (..), runBoolean, runFunction, runValueErrorWith)
|
||||
import Data.Abstract.Value.Type as Type
|
||||
import Data.Blob
|
||||
import Data.Coerce
|
||||
import Data.Graph
|
||||
import Data.Graph.ControlFlowVertex (VertexDeclarationStrategy, VertexDeclarationWithStrategy)
|
||||
import Data.Language as Language
|
||||
@ -110,7 +109,7 @@ runCallGraph lang includePackages modules package = do
|
||||
extractGraph (graph, _) = simplify graph
|
||||
runGraphAnalysis
|
||||
= graphing @_ @_ @(Maybe Name) @Monovariant
|
||||
. runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) Abstract))
|
||||
. runHeap
|
||||
. caching
|
||||
. runFresh 0
|
||||
. resumingLoadError
|
||||
@ -129,7 +128,7 @@ runCallGraph lang includePackages modules package = do
|
||||
runAddressEffects
|
||||
= Hole.runAllocator (Located.handleAllocator Monovariant.handleAllocator)
|
||||
. Hole.runDeref (Located.handleDeref Monovariant.handleDeref)
|
||||
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects (Abstract.runBoolean . Abstract.runFunction) modules))
|
||||
extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm runAddressEffects (fmap Abstract.runBoolean . Abstract.runFunction) modules))
|
||||
|
||||
runImportGraphToModuleInfos :: ( Declarations term
|
||||
, Evaluatable (Base term)
|
||||
@ -139,6 +138,7 @@ runImportGraphToModuleInfos :: ( Declarations term
|
||||
, Member Trace effs
|
||||
, Recursive term
|
||||
, Effects effs
|
||||
, Show term
|
||||
)
|
||||
=> Proxy lang
|
||||
-> Package term
|
||||
@ -154,6 +154,7 @@ runImportGraphToModules :: ( Declarations term
|
||||
, Member Trace effs
|
||||
, Recursive term
|
||||
, Effects effs
|
||||
, Show term
|
||||
)
|
||||
=> Proxy lang
|
||||
-> Package term
|
||||
@ -169,6 +170,7 @@ runImportGraph :: ( Declarations term
|
||||
, Member Trace effs
|
||||
, Recursive term
|
||||
, Effects effs
|
||||
, Show term
|
||||
)
|
||||
=> Proxy lang
|
||||
-> Package term
|
||||
@ -179,7 +181,7 @@ runImportGraph lang (package :: Package term) f =
|
||||
extractGraph (graph, _) = graph >>= f
|
||||
runImportGraphAnalysis
|
||||
= runState lowerBound
|
||||
. runState lowerBound
|
||||
. runHeap
|
||||
. runFresh 0
|
||||
. resumingLoadError
|
||||
. resumingUnspecialized
|
||||
@ -188,39 +190,19 @@ runImportGraph lang (package :: Package term) f =
|
||||
. resumingResolutionError
|
||||
. resumingAddressError
|
||||
. resumingValueError
|
||||
. runReader lowerBound
|
||||
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) Precise))))))
|
||||
. runModules (ModuleTable.modulePaths (packageModules package))
|
||||
. runReader (packageInfo package)
|
||||
. runState lowerBound
|
||||
. runReader lowerBound
|
||||
. runState (lowerBound @Span)
|
||||
. runReader (lowerBound @Span)
|
||||
runAddressEffects
|
||||
= Hole.runAllocator Precise.handleAllocator
|
||||
. Hole.runDeref Precise.handleDeref
|
||||
in extractGraph <$> runEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _)) (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (Concrete.runBoolean . Concrete.runFunction coerce coerce) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
|
||||
in extractGraph <$> runEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) _) (runImportGraphAnalysis (evaluate lang analyzeModule id runAddressEffects (fmap Concrete.runBoolean . Concrete.runFunction) (ModuleTable.toPairs (packageModules package) >>= toList . snd)))
|
||||
|
||||
type ConcreteEffects address rest
|
||||
= Reader Span
|
||||
': State Span
|
||||
': Reader PackageInfo
|
||||
': Modules address
|
||||
': Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))
|
||||
': Resumable (BaseError (ValueError address (ConcreteEff address rest)))
|
||||
': Resumable (BaseError (AddressError address (Value address (ConcreteEff address rest))))
|
||||
': Resumable (BaseError ResolutionError)
|
||||
': Resumable (BaseError EvalError)
|
||||
': Resumable (BaseError (EnvironmentError address))
|
||||
': Resumable (BaseError (UnspecializedError (Value address (ConcreteEff address rest))))
|
||||
': Resumable (BaseError (LoadError address))
|
||||
': Fresh
|
||||
': State (Heap address (Value address (ConcreteEff address rest)))
|
||||
': rest
|
||||
|
||||
newtype ConcreteEff address outerEffects a = ConcreteEff
|
||||
{ runConcreteEff :: Eff (ValueEffects address (Value address (ConcreteEff address outerEffects))
|
||||
(ModuleEffects address (Value address (ConcreteEff address outerEffects))
|
||||
(ConcreteEffects address outerEffects))) a
|
||||
}
|
||||
|
||||
runHeap :: Effects effects => Evaluator term address value (State (Heap address value) ': effects) a -> Evaluator term address value effects (Heap address value, a)
|
||||
runHeap = runState lowerBound
|
||||
|
||||
-- | Parse a list of files into a 'Package'.
|
||||
parsePackage :: (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs)
|
||||
@ -259,9 +241,9 @@ parsePythonPackage :: forall syntax fields effs term.
|
||||
-> Project -- ^ Project to parse into a package.
|
||||
-> Eff effs (Package term)
|
||||
parsePythonPackage parser project = do
|
||||
let runAnalysis = runEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _))
|
||||
let runAnalysis = runEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) term)
|
||||
. runState PythonPackage.Unknown
|
||||
. runState lowerBound
|
||||
. runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Value (Hole (Maybe Name) Precise) term)))
|
||||
. runFresh 0
|
||||
. resumingLoadError
|
||||
. resumingUnspecialized
|
||||
@ -270,11 +252,11 @@ parsePythonPackage parser project = do
|
||||
. resumingResolutionError
|
||||
. resumingAddressError
|
||||
. resumingValueError
|
||||
. runReader lowerBound
|
||||
. runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) Precise))))))
|
||||
. runModules lowerBound
|
||||
. runReader (PackageInfo (name "setup") lowerBound)
|
||||
. runState lowerBound
|
||||
. runReader lowerBound
|
||||
. runState (lowerBound @Span)
|
||||
. runReader (lowerBound @Span)
|
||||
runAddressEffects
|
||||
= Hole.runAllocator Precise.handleAllocator
|
||||
. Hole.runDeref Precise.handleDeref
|
||||
@ -282,7 +264,7 @@ parsePythonPackage parser project = do
|
||||
strat <- case find ((== (projectRootDir project </> "setup.py")) . filePath) (projectFiles project) of
|
||||
Just setupFile -> do
|
||||
setupModule <- fmap snd <$> parseModule project parser setupFile
|
||||
fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id runAddressEffects (Concrete.runBoolean . Concrete.runFunction coerce coerce . runPythonPackaging) [ setupModule ])
|
||||
fst <$> runAnalysis (evaluate (Proxy @'Language.Python) id id runAddressEffects (\ eval -> Concrete.runBoolean . Concrete.runFunction eval . runPythonPackaging) [ setupModule ])
|
||||
Nothing -> pure PythonPackage.Unknown
|
||||
case strat of
|
||||
PythonPackage.Unknown -> do
|
||||
@ -389,9 +371,10 @@ resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressE
|
||||
resumingValueError :: ( Effects effects
|
||||
, Member Trace effects
|
||||
, Show address
|
||||
, Show term
|
||||
)
|
||||
=> Evaluator term address (Value address body) (Resumable (BaseError (ValueError address body)) ': effects) a
|
||||
-> Evaluator term address (Value address body) effects a
|
||||
=> Evaluator term address (Value address term) (Resumable (BaseError (ValueError address term)) ': effects) a
|
||||
-> Evaluator term address (Value address term) effects a
|
||||
resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of
|
||||
CallError val -> pure val
|
||||
StringError val -> pure (pack (prettyShow val))
|
||||
|
||||
@ -14,7 +14,6 @@ import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Abstract.Package
|
||||
import Data.Abstract.Value.Concrete as Concrete
|
||||
import Data.Blob (Blob(..))
|
||||
import Data.Coerce
|
||||
import Data.Error (showExcerpt)
|
||||
import Data.Graph (topologicalSort)
|
||||
import Data.Language as Language
|
||||
@ -89,9 +88,9 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
|
||||
. fmap snd
|
||||
. runState ([] @Breakpoint)
|
||||
. runReader Step
|
||||
. id @(Evaluator _ Precise (Value Precise (ConcreteEff Precise _)) _ _)
|
||||
. id @(Evaluator _ Precise (Value Precise _) _ _)
|
||||
. runPrintingTrace
|
||||
. runState lowerBound
|
||||
. runHeap
|
||||
. runFresh 0
|
||||
. fmap reassociate
|
||||
. runLoadError
|
||||
@ -106,7 +105,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD
|
||||
. runReader (packageInfo package)
|
||||
. runState (lowerBound @Span)
|
||||
. runReader (lowerBound @Span)
|
||||
$ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules
|
||||
$ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (fmap Concrete.runBoolean . Concrete.runFunction) modules
|
||||
|
||||
-- TODO: REPL for typechecking/abstract semantics
|
||||
-- TODO: drive the flow from within the REPL instead of from without
|
||||
|
||||
@ -19,7 +19,6 @@ import Data.Abstract.Package
|
||||
import Data.Abstract.Value.Concrete as Concrete
|
||||
import Data.Abstract.Value.Type as Type
|
||||
import Data.Blob
|
||||
import Data.Coerce
|
||||
import Data.Graph (topologicalSort)
|
||||
import qualified Data.Language as Language
|
||||
import Data.List (uncons)
|
||||
@ -42,7 +41,7 @@ import Text.Show.Pretty (ppShow)
|
||||
justEvaluating
|
||||
= runM
|
||||
. runPrintingTrace
|
||||
. runState lowerBound
|
||||
. runHeap
|
||||
. runFresh 0
|
||||
. fmap reassociate
|
||||
. runLoadError
|
||||
@ -101,26 +100,26 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either
|
||||
package <- fmap (quieterm . snd) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) [])
|
||||
modules <- topologicalSort <$> runImportGraphToModules proxy package
|
||||
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
|
||||
pure (id @(Evaluator _ Precise (Value Precise (ConcreteEff Precise _)) _ _)
|
||||
pure (id @(Evaluator _ Precise (Value Precise _) _ _)
|
||||
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
|
||||
(runModules (ModuleTable.modulePaths (packageModules package))
|
||||
(runReader (packageInfo package)
|
||||
(runState (lowerBound @Span)
|
||||
(runReader (lowerBound @Span)
|
||||
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules)))))))
|
||||
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap Concrete.runBoolean . Concrete.runFunction) modules)))))))
|
||||
|
||||
evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do
|
||||
project <- readProject Nothing path lang []
|
||||
package <- fmap quieterm <$> parsePythonPackage parser project
|
||||
modules <- topologicalSort <$> runImportGraphToModules proxy package
|
||||
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
|
||||
pure (id @(Evaluator _ Precise (Value Precise (ConcreteEff Precise _)) _ _)
|
||||
pure (id @(Evaluator _ Precise (Value Precise _) _ _)
|
||||
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise)))))
|
||||
(runModules (ModuleTable.modulePaths (packageModules package))
|
||||
(runReader (packageInfo package)
|
||||
(runState (lowerBound @Span)
|
||||
(runReader (lowerBound @Span)
|
||||
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules)))))))
|
||||
(evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (fmap Concrete.runBoolean . Concrete.runFunction) modules)))))))
|
||||
|
||||
|
||||
evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do
|
||||
@ -132,7 +131,7 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $
|
||||
(runReader (lowerBound @Span)
|
||||
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant)))))
|
||||
(runModules (ModuleTable.modulePaths (packageModules package))
|
||||
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runFunction) modules))))))
|
||||
(evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (fmap Type.runBoolean . Type.runFunction) modules))))))
|
||||
|
||||
|
||||
parseFile :: Parser term -> FilePath -> IO term
|
||||
|
||||
@ -97,31 +97,33 @@ readFilePair :: Both FilePath -> IO BlobPair
|
||||
readFilePair paths = let paths' = fmap file paths in
|
||||
runBothWith IO.readFilePair paths'
|
||||
|
||||
type TestEvaluatingEffects = '[ Resumable (BaseError (ValueError Precise (ConcreteEff Precise '[Trace, Lift IO])))
|
||||
, Resumable (BaseError (AddressError Precise Val))
|
||||
type TestEvaluatingEffects term
|
||||
= '[ Resumable (BaseError (ValueError Precise term))
|
||||
, Resumable (BaseError (AddressError Precise (Val term)))
|
||||
, Resumable (BaseError ResolutionError)
|
||||
, Resumable (BaseError EvalError)
|
||||
, Resumable (BaseError (EnvironmentError Precise))
|
||||
, Resumable (BaseError (UnspecializedError Val))
|
||||
, Resumable (BaseError (UnspecializedError (Val term)))
|
||||
, Resumable (BaseError (LoadError Precise))
|
||||
, Fresh
|
||||
, State (Heap Precise Val)
|
||||
, State (Heap Precise (Val term))
|
||||
, Trace
|
||||
, Lift IO
|
||||
]
|
||||
type TestEvaluatingErrors = '[ BaseError (ValueError Precise (ConcreteEff Precise '[Trace, Lift IO]))
|
||||
, BaseError (AddressError Precise Val)
|
||||
type TestEvaluatingErrors term
|
||||
= '[ BaseError (ValueError Precise term)
|
||||
, BaseError (AddressError Precise (Val term))
|
||||
, BaseError ResolutionError
|
||||
, BaseError EvalError
|
||||
, BaseError (EnvironmentError Precise)
|
||||
, BaseError (UnspecializedError Val)
|
||||
, BaseError (UnspecializedError (Val term))
|
||||
, BaseError (LoadError Precise)
|
||||
]
|
||||
testEvaluating :: Evaluator term Precise Val TestEvaluatingEffects (Span, a)
|
||||
testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingEffects term) (Span, a)
|
||||
-> IO
|
||||
( [String]
|
||||
, ( Heap Precise Val
|
||||
, Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
|
||||
, ( Heap Precise (Val term)
|
||||
, Either (SomeExc (Data.Sum.Sum (TestEvaluatingErrors term)))
|
||||
a
|
||||
)
|
||||
)
|
||||
@ -137,10 +139,10 @@ testEvaluating
|
||||
. runEvalError
|
||||
. runResolutionError
|
||||
. runAddressError
|
||||
. runValueError @_ @_ @Precise @(ConcreteEff Precise _)
|
||||
. runValueError @_ @_ @Precise
|
||||
. fmap snd
|
||||
|
||||
type Val = Value Precise (ConcreteEff Precise '[Trace, Lift IO])
|
||||
type Val = Value Precise
|
||||
|
||||
|
||||
deNamespace :: Heap Precise (Value Precise term)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user