mirror of
https://github.com/github/semantic.git
synced 2024-12-11 08:45:48 +03:00
Merge branch 'master' into update-fastsum
This commit is contained in:
Patrick Thomson
GitHub
commit
28803beefd
@ -7,6 +7,7 @@ module Analysis.Abstract.Caching
|
||||
|
||||
import Control.Abstract
|
||||
import Data.Abstract.Cache
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Module
|
||||
import Data.Semilattice.Lower
|
||||
import Prologue
|
||||
@ -35,8 +36,8 @@ lookupCache configuration = cacheLookup configuration <$> get
|
||||
cachingConfiguration :: (Cacheable term location (Cell location) value, Members '[State (Cache term location (Cell location) value), State (Heap location (Cell location) value)] effects)
|
||||
=> Configuration term location (Cell location) value
|
||||
-> Set (Cached location (Cell location) value)
|
||||
-> TermEvaluator term location value effects value
|
||||
-> TermEvaluator term location value effects value
|
||||
-> TermEvaluator term location value effects (ValueRef value)
|
||||
-> TermEvaluator term location value effects (ValueRef value)
|
||||
cachingConfiguration configuration values action = do
|
||||
modify' (cacheSet configuration values)
|
||||
result <- Cached <$> action <*> TermEvaluator getHeap
|
||||
@ -66,8 +67,8 @@ cachingTerms :: ( Cacheable term location (Cell location) value
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
)
|
||||
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects value)
|
||||
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects value)
|
||||
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects (ValueRef value))
|
||||
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects (ValueRef value))
|
||||
cachingTerms recur term = do
|
||||
c <- getConfiguration (embedSubterm term)
|
||||
cached <- lookupCache c
|
||||
@ -77,11 +78,17 @@ cachingTerms recur term = do
|
||||
pairs <- consultOracle c
|
||||
cachingConfiguration c pairs (recur term)
|
||||
|
||||
convergingModules :: ( Cacheable term location (Cell location) value
|
||||
convergingModules :: ( AbstractValue location value effects
|
||||
, Addressable location effects
|
||||
, Cacheable term location (Cell location) value
|
||||
, Members '[ Fresh
|
||||
, NonDet
|
||||
, Reader (Cache term location (Cell location) value)
|
||||
, Reader (Environment location value)
|
||||
, Reader (Live location value)
|
||||
, Resumable (AddressError location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, Resumable (EvalError value)
|
||||
, State (Cache term location (Cell location) value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
@ -103,7 +110,7 @@ convergingModules recur m = do
|
||||
-- would never complete). We don’t need to use the values, so we 'gather' the
|
||||
-- nondeterministic values into @()@.
|
||||
withOracle prevCache (gatherM (const ()) (recur m)))
|
||||
maybe empty scatter (cacheLookup c cache)
|
||||
TermEvaluator (value =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache)))
|
||||
|
||||
|
||||
-- | Iterate a monadic action starting from some initial seed until the results converge.
|
||||
@ -122,7 +129,7 @@ converge seed f = loop seed
|
||||
loop x'
|
||||
|
||||
-- | Nondeterministically write each of a collection of stores & return their associated results.
|
||||
scatter :: (Foldable t, Members '[NonDet, State (Heap location (Cell location) value)] effects) => t (Cached location (Cell location) value) -> TermEvaluator term location value effects value
|
||||
scatter :: (Foldable t, Members '[NonDet, State (Heap location (Cell location) value)] effects) => t (Cached location (Cell location) value) -> TermEvaluator term location value effects (ValueRef value)
|
||||
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)
|
||||
|
||||
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
|
||||
module Control.Abstract.Evaluator
|
||||
( Evaluator(..)
|
||||
, ValueRef(..)
|
||||
-- * Effects
|
||||
, Return(..)
|
||||
, earlyReturn
|
||||
@ -29,6 +30,7 @@ import Control.Monad.Effect.Reader
|
||||
import Control.Monad.Effect.Resumable
|
||||
import Control.Monad.Effect.State
|
||||
import Control.Monad.Effect.Trace
|
||||
import Data.Abstract.FreeVariables
|
||||
import Prologue
|
||||
|
||||
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types.
|
||||
@ -41,6 +43,16 @@ newtype Evaluator location value effects a = Evaluator { runEvaluator :: Eff eff
|
||||
|
||||
deriving instance Member NonDet effects => Alternative (Evaluator location value effects)
|
||||
|
||||
-- | 'ValueRef' is the type subterms evaluate to and can represent either values directly ('Rval'), or references to values (lvals - such as local variables or object members)
|
||||
data ValueRef value where
|
||||
-- Represents a value:
|
||||
Rval :: value -> ValueRef value
|
||||
-- Represents a local variable. No environment is attached - it's assumed that LvalLocal will be evaluated in the same scope it was constructed:
|
||||
LvalLocal :: Name -> ValueRef value
|
||||
-- Represents an object member:
|
||||
LvalMember :: value -> Name -> ValueRef value
|
||||
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- Effects
|
||||
|
||||
|
||||
@ -138,8 +138,8 @@ class Show value => AbstractValue location value effects where
|
||||
scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location value))
|
||||
|
||||
-- | Build a closure (a binder like a lambda or method definition).
|
||||
closure :: [Name] -- ^ The parameter names.
|
||||
-> Set Name -- ^ The set of free variables to close over.
|
||||
closure :: [Name] -- ^ The parameter names.
|
||||
-> Set Name -- ^ The set of free variables to close over.
|
||||
-> Evaluator location value effects value -- ^ The evaluator for the body of the closure.
|
||||
-> Evaluator location value effects value
|
||||
-- | Evaluate an application (like a function call).
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-}
|
||||
module Data.Abstract.Cache where
|
||||
|
||||
import Control.Abstract.Evaluator
|
||||
import Data.Abstract.Configuration
|
||||
import Data.Abstract.Heap
|
||||
import Data.Map.Monoidal as Monoidal
|
||||
@ -12,7 +13,7 @@ newtype Cache term location cell value = Cache { unCache :: Monoidal.Map (Config
|
||||
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term location cell value, Cached location cell value), Semigroup)
|
||||
|
||||
data Cached location cell value = Cached
|
||||
{ cachedValue :: value
|
||||
{ cachedValue :: ValueRef value
|
||||
, cachedHeap :: Heap location cell value
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
@ -8,6 +8,8 @@ module Data.Abstract.Evaluatable
|
||||
, EvalError(..)
|
||||
, runEvalError
|
||||
, runEvalErrorWith
|
||||
, value
|
||||
, subtermValue
|
||||
, evaluateInScopedEnv
|
||||
, evaluatePackageWith
|
||||
, throwEvalError
|
||||
@ -44,8 +46,8 @@ class Evaluatable constr where
|
||||
eval :: ( EvaluatableConstraints location term value effects
|
||||
, Member Fail effects
|
||||
)
|
||||
=> SubtermAlgebra constr term (Evaluator location value effects value)
|
||||
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator location value effects value)
|
||||
=> SubtermAlgebra constr term (Evaluator location value effects (ValueRef value))
|
||||
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator location value effects (ValueRef value))
|
||||
eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
|
||||
|
||||
type EvaluatableConstraints location term value effects =
|
||||
@ -126,7 +128,7 @@ throwEvalError = throwResumable
|
||||
|
||||
|
||||
data Unspecialized a b where
|
||||
Unspecialized :: Prelude.String -> Unspecialized value value
|
||||
Unspecialized :: Prelude.String -> Unspecialized value (ValueRef value)
|
||||
|
||||
instance Eq1 (Unspecialized a) where
|
||||
liftEq _ (Unspecialized a) (Unspecialized b) = a == b
|
||||
@ -136,13 +138,44 @@ deriving instance Show (Unspecialized a b)
|
||||
instance Show1 (Unspecialized a) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
|
||||
-- | Evaluates a 'Value' returning the referenced value
|
||||
value :: ( Addressable location effects
|
||||
, AbstractValue location value effects
|
||||
, Members '[ Reader (Environment location value)
|
||||
, Resumable (AddressError location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, Resumable (EvalError value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
)
|
||||
=> ValueRef value
|
||||
-> Evaluator location value effects value
|
||||
value (LvalLocal var) = variable var
|
||||
value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
|
||||
value (Rval val) = pure val
|
||||
|
||||
-- | Evaluates a 'Subterm' to its rval
|
||||
subtermValue :: ( Addressable location effects
|
||||
, AbstractValue location value effects
|
||||
, Members '[ Reader (Environment location value)
|
||||
, Resumable (AddressError location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, Resumable (EvalError value)
|
||||
, State (Environment location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
] effects
|
||||
)
|
||||
=> Subterm term (Evaluator location value effects (ValueRef value))
|
||||
-> Evaluator location value effects value
|
||||
subtermValue = value <=< subtermRef
|
||||
|
||||
runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a)
|
||||
runUnspecialized = runResumable
|
||||
|
||||
runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a
|
||||
runUnspecializedWith = runResumableWith
|
||||
|
||||
|
||||
-- Instances
|
||||
|
||||
-- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'.
|
||||
@ -160,7 +193,7 @@ instance Evaluatable s => Evaluatable (TermF s a) where
|
||||
--- 3. Only the last statement’s return value is returned.
|
||||
instance Evaluatable [] where
|
||||
-- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
|
||||
eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty
|
||||
eval = maybe (Rval <$> unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty
|
||||
|
||||
|
||||
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects ()
|
||||
@ -204,7 +237,7 @@ evaluatePackageWith :: forall location term value inner inner' outer
|
||||
, inner' ~ (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
||||
)
|
||||
=> (SubtermAlgebra Module term (TermEvaluator term location value inner value) -> SubtermAlgebra Module term (TermEvaluator term location value inner value))
|
||||
-> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner value) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner value))
|
||||
-> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)))
|
||||
-> Package term
|
||||
-> TermEvaluator term location value outer [value]
|
||||
evaluatePackageWith analyzeModule analyzeTerm package
|
||||
@ -216,11 +249,13 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
||||
. withPrelude (packagePrelude (packageBody package))
|
||||
. raiseHandler (runModules (runTermEvaluator . evalModule))
|
||||
$ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints (packageBody package)))
|
||||
where evalModule m
|
||||
where
|
||||
evalModule m
|
||||
= pairValueWithEnv
|
||||
. runInModule (moduleInfo m)
|
||||
. analyzeModule (subtermValue . moduleBody)
|
||||
$ fmap (Subterm <*> foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator)))) m
|
||||
. analyzeModule (subtermRef . moduleBody)
|
||||
$ evalTerm <$> m
|
||||
evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term)))
|
||||
|
||||
runInModule info
|
||||
= runReader info
|
||||
|
||||
@ -9,6 +9,7 @@ module Data.Abstract.Type
|
||||
|
||||
import Control.Abstract
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Semigroup.Foldable (foldMap1)
|
||||
import Data.Semigroup.Reducer (Reducer)
|
||||
import Prologue hiding (TypeError)
|
||||
@ -105,6 +106,9 @@ instance AbstractHole Type where
|
||||
instance ( Addressable location effects
|
||||
, Members '[ Fresh
|
||||
, NonDet
|
||||
, Reader (Environment location Type)
|
||||
, Resumable (AddressError location Type)
|
||||
, Resumable (EvalError Type)
|
||||
, Resumable TypeError
|
||||
, Return Type
|
||||
, State (Environment location Type)
|
||||
|
||||
@ -48,7 +48,7 @@ type OpenFAlgebra f a = forall b . (b -> a) -> f b -> a
|
||||
type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a
|
||||
|
||||
-- | A subterm and its computed value, used in 'SubtermAlgebra'.
|
||||
data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a }
|
||||
data Subterm t a = Subterm { subterm :: !t, subtermRef :: !a }
|
||||
deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
|
||||
|
||||
instance Bifunctor Subterm where
|
||||
|
||||
@ -112,7 +112,7 @@ instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Identifier
|
||||
|
||||
instance Evaluatable Identifier where
|
||||
eval (Identifier name) = variable name
|
||||
eval (Identifier name) = pure (LvalLocal name)
|
||||
|
||||
instance FreeVariables1 Identifier where
|
||||
liftFreeVariables _ (Identifier x) = pure x
|
||||
@ -158,7 +158,7 @@ instance Ord1 Empty where liftCompare _ _ _ = EQ
|
||||
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
|
||||
|
||||
instance Evaluatable Empty where
|
||||
eval _ = unit
|
||||
eval _ = Rval <$> unit
|
||||
|
||||
|
||||
-- | Syntax representing a parsing or assignment error.
|
||||
@ -227,4 +227,4 @@ instance Ord1 Context where liftCompare = genericLiftCompare
|
||||
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Context where
|
||||
eval Context{..} = subtermValue contextSubject
|
||||
eval Context{..} = subtermRef contextSubject
|
||||
|
||||
@ -19,7 +19,7 @@ instance ToJSONFields1 Comment where
|
||||
toJSONFields1 f@Comment{..} = withChildren f ["contents" .= unpack commentContent ]
|
||||
|
||||
instance Evaluatable Comment where
|
||||
eval _ = unit
|
||||
eval _ = Rval <$> unit
|
||||
|
||||
-- TODO: nested comment types
|
||||
-- TODO: documentation comment types
|
||||
|
||||
@ -28,7 +28,7 @@ instance Evaluatable Function where
|
||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
|
||||
(v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
|
||||
modifyEnv (Env.insert name addr)
|
||||
pure v
|
||||
pure (Rval v)
|
||||
where paramNames = foldMap (freeVariables . subterm)
|
||||
|
||||
instance Declarations a => Declarations (Function a) where
|
||||
@ -54,7 +54,7 @@ instance Evaluatable Method where
|
||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
|
||||
(v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
|
||||
modifyEnv (Env.insert name addr)
|
||||
pure v
|
||||
pure (Rval v)
|
||||
where paramNames = foldMap (freeVariables . subterm)
|
||||
|
||||
|
||||
@ -112,8 +112,8 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 VariableDeclaration
|
||||
|
||||
instance Evaluatable VariableDeclaration where
|
||||
eval (VariableDeclaration []) = unit
|
||||
eval (VariableDeclaration decs) = multiple =<< traverse subtermValue decs
|
||||
eval (VariableDeclaration []) = Rval <$> unit
|
||||
eval (VariableDeclaration decs) = Rval <$> (multiple =<< traverse subtermValue decs)
|
||||
|
||||
instance Declarations a => Declarations (VariableDeclaration a) where
|
||||
declaredName (VariableDeclaration vars) = case vars of
|
||||
@ -187,7 +187,7 @@ instance Evaluatable Class where
|
||||
void $ subtermValue classBody
|
||||
classEnv <- Env.head <$> getEnv
|
||||
klass name supers classEnv
|
||||
v <$ modifyEnv (Env.insert name addr)
|
||||
Rval <$> (v <$ modifyEnv (Env.insert name addr))
|
||||
|
||||
-- | A decorator in Python
|
||||
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
|
||||
@ -278,7 +278,7 @@ instance Evaluatable TypeAlias where
|
||||
v <- subtermValue typeAliasKind
|
||||
addr <- lookupOrAlloc name
|
||||
assign addr v
|
||||
modifyEnv (Env.insert name addr) $> v
|
||||
Rval <$> (modifyEnv (Env.insert name addr) $> v)
|
||||
|
||||
instance Declarations a => Declarations (TypeAlias a) where
|
||||
declaredName TypeAlias{..} = declaredName typeAliasIdentifier
|
||||
|
||||
@ -20,7 +20,7 @@ instance Show1 File where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 File
|
||||
|
||||
instance Evaluatable File where
|
||||
eval File = currentModule >>= string . BC.pack . modulePath
|
||||
eval File = Rval <$> (currentModule >>= string . BC.pack . modulePath)
|
||||
|
||||
|
||||
-- A line directive like the Ruby constant `__LINE__`.
|
||||
@ -34,4 +34,4 @@ instance Show1 Line where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Line
|
||||
|
||||
instance Evaluatable Line where
|
||||
eval Line = currentSpan >>= integer . fromIntegral . posLine . spanStart
|
||||
eval Line = Rval <$> (currentSpan >>= integer . fromIntegral . posLine . spanStart)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
|
||||
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
|
||||
module Data.Syntax.Expression where
|
||||
|
||||
import Data.Abstract.Evaluatable
|
||||
@ -21,7 +21,7 @@ instance ToJSONFields1 Call
|
||||
instance Evaluatable Call where
|
||||
eval Call{..} = do
|
||||
op <- subtermValue callFunction
|
||||
call op (map subtermValue callParams)
|
||||
Rval <$> call op (map subtermValue callParams)
|
||||
|
||||
data Comparison a
|
||||
= LessThan !a !a
|
||||
@ -39,7 +39,7 @@ instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Comparison
|
||||
|
||||
instance Evaluatable Comparison where
|
||||
eval = traverse subtermValue >=> go where
|
||||
eval t = Rval <$> (traverse subtermValue t >>= go) where
|
||||
go x = case x of
|
||||
(LessThan a b) -> liftComparison (Concrete (<)) a b
|
||||
(LessThanEqual a b) -> liftComparison (Concrete (<=)) a b
|
||||
@ -67,7 +67,7 @@ instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Arithmetic
|
||||
|
||||
instance Evaluatable Arithmetic where
|
||||
eval = traverse subtermValue >=> go where
|
||||
eval t = Rval <$> (traverse subtermValue t >>= go) where
|
||||
go (Plus a b) = liftNumeric2 add a b where add = liftReal (+)
|
||||
go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-)
|
||||
go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*)
|
||||
@ -108,7 +108,7 @@ instance ToJSONFields1 Boolean
|
||||
|
||||
instance Evaluatable Boolean where
|
||||
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
|
||||
eval = go . fmap subtermValue where
|
||||
eval t = Rval <$> go (fmap subtermValue t) where
|
||||
go (And a b) = do
|
||||
cond <- a
|
||||
ifthenelse cond b (pure cond)
|
||||
@ -192,7 +192,7 @@ instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Bitwise
|
||||
|
||||
instance Evaluatable Bitwise where
|
||||
eval = traverse subtermValue >=> go where
|
||||
eval t = Rval <$> (traverse subtermValue t >>= go) where
|
||||
genLShift x y = shiftL x (fromIntegral y)
|
||||
genRShift x y = shiftR x (fromIntegral y)
|
||||
go x = case x of
|
||||
@ -216,7 +216,12 @@ instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 MemberAccess
|
||||
|
||||
instance Evaluatable MemberAccess where
|
||||
eval (fmap subtermValue -> MemberAccess mem acc) = evaluateInScopedEnv mem acc
|
||||
eval (MemberAccess obj prop) = do
|
||||
obj <- subtermValue obj
|
||||
prop <- subtermRef prop
|
||||
case prop of
|
||||
LvalLocal propName -> pure (LvalMember obj propName)
|
||||
_ -> raiseEff (Prologue.fail "Non-Identifier as right hand side of MemberAccess!")
|
||||
|
||||
-- | Subscript (e.g a[1])
|
||||
data Subscript a
|
||||
@ -231,8 +236,9 @@ instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Subscript
|
||||
|
||||
-- TODO: Finish Eval instance for Subscript
|
||||
-- TODO return a special LvalSubscript instance here
|
||||
instance Evaluatable Subscript where
|
||||
eval (Subscript l [r]) = join (index <$> subtermValue l <*> subtermValue r)
|
||||
eval (Subscript l [r]) = Rval <$> join (index <$> subtermValue l <*> subtermValue r)
|
||||
eval (Subscript _ _) = throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
|
||||
eval (Member _ _) = throwResumable (Unspecialized "Eval unspecialized for member access")
|
||||
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns #-}
|
||||
module Data.Syntax.Literal where
|
||||
|
||||
import Control.Arrow ((>>>))
|
||||
import Data.JSON.Fields
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.ByteString.Char8 (readInteger, unpack)
|
||||
@ -28,7 +27,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
|
||||
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Boolean where
|
||||
eval (Boolean x) = boolean x
|
||||
eval (Boolean x) = Rval <$> boolean x
|
||||
|
||||
instance ToJSONFields1 Boolean where
|
||||
toJSONFields1 (Boolean b) = noChildren [ "value" .= b ]
|
||||
@ -46,7 +45,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
|
||||
instance Evaluatable Data.Syntax.Literal.Integer where
|
||||
-- TODO: This instance probably shouldn't have readInteger?
|
||||
eval (Data.Syntax.Literal.Integer x) =
|
||||
integer =<< maybeM (throwEvalError (IntegerFormatError x)) (fst <$> readInteger x)
|
||||
Rval <$> (integer =<< maybeM (throwEvalError (IntegerFormatError x)) (fst <$> readInteger x))
|
||||
|
||||
instance ToJSONFields1 Data.Syntax.Literal.Integer where
|
||||
toJSONFields1 (Integer i) = noChildren ["asString" .= unpack i]
|
||||
@ -66,7 +65,7 @@ instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsP
|
||||
|
||||
instance Evaluatable Data.Syntax.Literal.Float where
|
||||
eval (Float s) =
|
||||
float =<< either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s)
|
||||
Rval <$> (float =<< either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s))
|
||||
|
||||
instance ToJSONFields1 Float where
|
||||
toJSONFields1 (Float f) = noChildren ["asString" .= unpack f]
|
||||
@ -84,7 +83,7 @@ instance Evaluatable Data.Syntax.Literal.Rational where
|
||||
let
|
||||
trimmed = B.takeWhile (/= 'r') r
|
||||
parsed = readMaybe @Prelude.Integer (unpack trimmed)
|
||||
in rational =<< maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed
|
||||
in Rval <$> (rational =<< maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed)
|
||||
|
||||
instance ToJSONFields1 Data.Syntax.Literal.Rational where
|
||||
toJSONFields1 (Rational r) = noChildren ["asString" .= unpack r]
|
||||
@ -144,7 +143,7 @@ instance ToJSONFields1 TextElement where
|
||||
toJSONFields1 (TextElement c) = noChildren ["asString" .= unpack c]
|
||||
|
||||
instance Evaluatable TextElement where
|
||||
eval (TextElement x) = string x
|
||||
eval (TextElement x) = Rval <$> string x
|
||||
|
||||
data Null a = Null
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -153,7 +152,7 @@ instance Eq1 Null where liftEq = genericLiftEq
|
||||
instance Ord1 Null where liftCompare = genericLiftCompare
|
||||
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Null where eval = const null
|
||||
instance Evaluatable Null where eval _ = Rval <$> null
|
||||
|
||||
instance ToJSONFields1 Null
|
||||
|
||||
@ -167,7 +166,7 @@ instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Symbol
|
||||
|
||||
instance Evaluatable Symbol where
|
||||
eval (Symbol s) = symbol s
|
||||
eval (Symbol s) = Rval <$> symbol s
|
||||
|
||||
newtype Regex a = Regex { regexContent :: ByteString }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -199,7 +198,7 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Array
|
||||
|
||||
instance Evaluatable Array where
|
||||
eval (Array a) = array =<< traverse subtermValue a
|
||||
eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
|
||||
|
||||
newtype Hash a = Hash { hashElements :: [a] }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -211,7 +210,7 @@ instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Hash
|
||||
|
||||
instance Evaluatable Hash where
|
||||
eval = hashElements >>> traverse (subtermValue >=> asPair) >=> hash
|
||||
eval t = Rval <$> (traverse (subtermValue >=> asPair) (hashElements t) >>= hash)
|
||||
|
||||
data KeyValue a = KeyValue { key :: !a, value :: !a }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -224,7 +223,7 @@ instance ToJSONFields1 KeyValue
|
||||
|
||||
instance Evaluatable KeyValue where
|
||||
eval (fmap subtermValue -> KeyValue{..}) =
|
||||
join (kvPair <$> key <*> value)
|
||||
Rval <$> join (kvPair <$> key <*> value)
|
||||
|
||||
instance ToJSONFields1 Tuple
|
||||
|
||||
@ -236,7 +235,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare
|
||||
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Tuple where
|
||||
eval (Tuple cs) = multiple =<< traverse subtermValue cs
|
||||
eval (Tuple cs) = Rval <$> (multiple =<< traverse subtermValue cs)
|
||||
|
||||
newtype Set a = Set { setElements :: [a] }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
|
||||
module Data.Syntax.Statement where
|
||||
|
||||
import Control.Abstract.Evaluator (ValueRef(..))
|
||||
import qualified Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.ByteString.Char8 (unpack)
|
||||
@ -22,7 +23,7 @@ instance ToJSONFields1 If
|
||||
instance Evaluatable If where
|
||||
eval (If cond if' else') = do
|
||||
bool <- subtermValue cond
|
||||
ifthenelse bool (subtermValue if') (subtermValue else')
|
||||
Rval <$> ifthenelse bool (subtermValue if') (subtermValue else')
|
||||
|
||||
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
|
||||
data Else a = Else { elseCondition :: !a, elseBody :: !a }
|
||||
@ -95,7 +96,7 @@ instance Evaluatable Let where
|
||||
eval Let{..} = do
|
||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm letVariable)
|
||||
addr <- snd <$> letrec name (subtermValue letValue)
|
||||
localEnv (Env.insert name addr) (subtermValue letBody)
|
||||
Rval <$> localEnv (Env.insert name addr) (subtermValue letBody)
|
||||
|
||||
|
||||
-- Assignment
|
||||
@ -112,13 +113,22 @@ instance ToJSONFields1 Assignment
|
||||
|
||||
instance Evaluatable Assignment where
|
||||
eval Assignment{..} = do
|
||||
case freeVariables (subterm assignmentTarget) of
|
||||
[name] -> do
|
||||
v <- subtermValue assignmentValue
|
||||
addr <- lookupOrAlloc name
|
||||
assign addr v
|
||||
modifyEnv (Env.insert name addr) $> v
|
||||
_ -> evaluateInScopedEnv (subtermValue assignmentTarget) (subtermValue assignmentValue)
|
||||
lhs <- subtermRef assignmentTarget
|
||||
rhs <- subtermValue assignmentValue
|
||||
|
||||
case lhs of
|
||||
LvalLocal nam -> do
|
||||
addr <- lookupOrAlloc nam
|
||||
assign addr rhs
|
||||
modifyEnv (Env.insert nam addr)
|
||||
LvalMember _ _ ->
|
||||
-- we don't yet support mutable object properties:
|
||||
pure ()
|
||||
Rval _ ->
|
||||
-- the left hand side of the assignment expression is invalid:
|
||||
pure ()
|
||||
|
||||
pure (Rval rhs)
|
||||
|
||||
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
|
||||
newtype PostIncrement a = PostIncrement a
|
||||
@ -160,7 +170,7 @@ instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Return
|
||||
|
||||
instance Evaluatable Return where
|
||||
eval (Return x) = subtermValue x >>= earlyReturn
|
||||
eval (Return x) = Rval <$> (subtermValue x >>= earlyReturn)
|
||||
|
||||
newtype Yield a = Yield a
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -185,7 +195,7 @@ instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Break
|
||||
|
||||
instance Evaluatable Break where
|
||||
eval (Break x) = subtermValue x >>= throwBreak
|
||||
eval (Break x) = Rval <$> (subtermValue x >>= throwBreak)
|
||||
|
||||
newtype Continue a = Continue a
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -197,7 +207,7 @@ instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Continue
|
||||
|
||||
instance Evaluatable Continue where
|
||||
eval (Continue a) = subtermValue a >>= throwContinue
|
||||
eval (Continue a) = Rval <$> (subtermValue a >>= throwContinue)
|
||||
|
||||
newtype Retry a = Retry a
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -222,7 +232,7 @@ instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 NoOp
|
||||
|
||||
instance Evaluatable NoOp where
|
||||
eval _ = unit
|
||||
eval _ = Rval <$> unit
|
||||
|
||||
-- Loops
|
||||
|
||||
@ -236,7 +246,7 @@ instance Show1 For where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 For
|
||||
|
||||
instance Evaluatable For where
|
||||
eval (fmap subtermValue -> For before cond step body) = forLoop before cond step body
|
||||
eval (fmap subtermValue -> For before cond step body) = Rval <$> forLoop before cond step body
|
||||
|
||||
|
||||
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
|
||||
@ -262,7 +272,7 @@ instance Show1 While where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 While
|
||||
|
||||
instance Evaluatable While where
|
||||
eval While{..} = while (subtermValue whileCondition) (subtermValue whileBody)
|
||||
eval While{..} = Rval <$> while (subtermValue whileCondition) (subtermValue whileBody)
|
||||
|
||||
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -274,7 +284,7 @@ instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 DoWhile
|
||||
|
||||
instance Evaluatable DoWhile where
|
||||
eval DoWhile{..} = doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition)
|
||||
eval DoWhile{..} = Rval <$> doWhile (subtermValue doWhileBody) (subtermValue doWhileCondition)
|
||||
|
||||
-- Exception handling
|
||||
|
||||
|
||||
@ -72,7 +72,7 @@ instance Evaluatable Import where
|
||||
traceResolve (unPath importPath) path
|
||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||
modifyEnv (mergeEnvs importedEnv)
|
||||
unit
|
||||
Rval <$> unit
|
||||
|
||||
|
||||
-- | Qualified Import declarations (symbols are qualified in calling environment).
|
||||
@ -97,7 +97,7 @@ instance Evaluatable QualifiedImport where
|
||||
importedEnv <- maybe emptyEnv fst <$> isolate (require p)
|
||||
modifyEnv (mergeEnvs importedEnv)
|
||||
makeNamespace alias addr Nothing
|
||||
unit
|
||||
Rval <$> unit
|
||||
|
||||
-- | Side effect only imports (no symbols made available to the calling environment).
|
||||
data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a }
|
||||
@ -114,7 +114,7 @@ instance Evaluatable SideEffectImport where
|
||||
paths <- resolveGoImport importPath
|
||||
traceResolve (unPath importPath) paths
|
||||
for_ paths $ \path -> isolate (require path)
|
||||
unit
|
||||
Rval <$> unit
|
||||
|
||||
-- A composite literal in Go
|
||||
data Composite a = Composite { compositeType :: !a, compositeElement :: !a }
|
||||
|
||||
@ -52,24 +52,30 @@ resolvePHPName n = do
|
||||
where name = toName n
|
||||
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
||||
|
||||
include :: ( AbstractValue location value effects
|
||||
include :: ( Addressable location effects
|
||||
, AbstractValue location value effects
|
||||
, Members '[ Modules location value
|
||||
, Reader (Environment location value)
|
||||
, Resumable ResolutionError
|
||||
, Resumable (AddressError location value)
|
||||
, Resumable (EnvironmentError value)
|
||||
, Resumable (EvalError value)
|
||||
, State (Environment location value)
|
||||
, State (Exports location value)
|
||||
, State (Heap location (Cell location) value)
|
||||
, Trace
|
||||
] effects
|
||||
)
|
||||
=> Subterm term (Evaluator location value effects value)
|
||||
=> Subterm term (Evaluator location value effects (ValueRef value))
|
||||
-> (ModulePath -> Evaluator location value effects (Maybe (Environment location value, value)))
|
||||
-> Evaluator location value effects value
|
||||
-> Evaluator location value effects (ValueRef value)
|
||||
include pathTerm f = do
|
||||
name <- subtermValue pathTerm >>= asString
|
||||
path <- resolvePHPName name
|
||||
traceResolve name path
|
||||
(importedEnv, v) <- isolate (f path) >>= maybeM ((,) emptyEnv <$> unit)
|
||||
modifyEnv (mergeEnvs importedEnv)
|
||||
pure v
|
||||
pure (Rval v)
|
||||
|
||||
newtype Require a = Require a
|
||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
|
||||
@ -236,7 +242,7 @@ instance Ord1 QualifiedName where liftCompare = genericLiftCompare
|
||||
instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable QualifiedName where
|
||||
eval (fmap subtermValue -> QualifiedName name iden) = evaluateInScopedEnv name iden
|
||||
eval (fmap subtermValue -> QualifiedName name iden) = Rval <$> evaluateInScopedEnv name iden
|
||||
|
||||
newtype NamespaceName a = NamespaceName (NonEmpty a)
|
||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
|
||||
@ -248,7 +254,7 @@ instance Ord1 NamespaceName where liftCompare = genericLiftCompare
|
||||
instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable NamespaceName where
|
||||
eval (NamespaceName xs) = foldl1 evaluateInScopedEnv $ fmap subtermValue xs
|
||||
eval (NamespaceName xs) = Rval <$> foldl1 evaluateInScopedEnv (fmap subtermValue xs)
|
||||
|
||||
newtype ConstDeclaration a = ConstDeclaration [a]
|
||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
|
||||
@ -441,7 +447,7 @@ instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
|
||||
instance ToJSONFields1 Namespace
|
||||
|
||||
instance Evaluatable Namespace where
|
||||
eval Namespace{..} = go names
|
||||
eval Namespace{..} = Rval <$> go names
|
||||
where
|
||||
names = freeVariables (subterm namespaceName)
|
||||
go [] = raiseEff (fail "expected at least one free variable in namespaceName, found none")
|
||||
|
||||
@ -111,7 +111,7 @@ instance Evaluatable Import where
|
||||
let path = NonEmpty.last modulePaths
|
||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||
modifyEnv (mergeEnvs (select importedEnv))
|
||||
unit
|
||||
Rval <$> unit
|
||||
where
|
||||
select importedEnv
|
||||
| Prologue.null xs = importedEnv
|
||||
@ -132,7 +132,7 @@ instance Evaluatable QualifiedImport where
|
||||
eval (QualifiedImport (RelativeQualifiedName _ _)) = raiseEff (fail "technically this is not allowed in python")
|
||||
eval (QualifiedImport name@(QualifiedName qualifiedName)) = do
|
||||
modulePaths <- resolvePythonModules name
|
||||
go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths)
|
||||
Rval <$> go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths)
|
||||
where
|
||||
-- Evaluate and import the last module, updating the environment
|
||||
go ((name, path) :| []) = letrec' name $ \addr -> do
|
||||
@ -165,12 +165,12 @@ instance Evaluatable QualifiedAliasedImport where
|
||||
|
||||
-- Evaluate and import the last module, aliasing and updating the environment
|
||||
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
|
||||
letrec' alias $ \addr -> do
|
||||
Rval <$> letrec' alias (\addr -> do
|
||||
let path = NonEmpty.last modulePaths
|
||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||
modifyEnv (mergeEnvs importedEnv)
|
||||
void $ makeNamespace alias addr Nothing
|
||||
unit
|
||||
unit)
|
||||
|
||||
-- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
|
||||
data Ellipsis a = Ellipsis
|
||||
|
||||
@ -57,7 +57,7 @@ instance Evaluatable Send where
|
||||
Just sel -> subtermValue sel
|
||||
Nothing -> variable (name "call")
|
||||
func <- maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver
|
||||
call func (map subtermValue sendArgs) -- TODO pass through sendBlock
|
||||
Rval <$> call func (map subtermValue sendArgs) -- TODO pass through sendBlock
|
||||
|
||||
data Require a = Require { requireRelative :: Bool, requirePath :: !a }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -75,7 +75,7 @@ instance Evaluatable Require where
|
||||
traceResolve name path
|
||||
(importedEnv, v) <- isolate (doRequire path)
|
||||
modifyEnv (`mergeNewer` importedEnv)
|
||||
pure v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
|
||||
pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
|
||||
|
||||
doRequire :: ( AbstractValue location value effects
|
||||
, Member (Modules location value) effects
|
||||
@ -101,11 +101,11 @@ instance ToJSONFields1 Load
|
||||
instance Evaluatable Load where
|
||||
eval (Load [x]) = do
|
||||
path <- subtermValue x >>= asString
|
||||
doLoad path False
|
||||
Rval <$> doLoad path False
|
||||
eval (Load [x, wrap]) = do
|
||||
path <- subtermValue x >>= asString
|
||||
shouldWrap <- subtermValue wrap >>= asBool
|
||||
doLoad path shouldWrap
|
||||
Rval <$> doLoad path shouldWrap
|
||||
eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required")
|
||||
|
||||
doLoad :: ( AbstractValue location value effects
|
||||
@ -144,8 +144,8 @@ instance Evaluatable Class where
|
||||
eval Class{..} = do
|
||||
super <- traverse subtermValue classSuperClass
|
||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
|
||||
letrec' name $ \addr ->
|
||||
subtermValue classBody <* makeNamespace name addr super
|
||||
Rval <$> letrec' name (\addr ->
|
||||
subtermValue classBody <* makeNamespace name addr super)
|
||||
|
||||
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -159,8 +159,8 @@ instance ToJSONFields1 Module
|
||||
instance Evaluatable Module where
|
||||
eval (Module iden xs) = do
|
||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
|
||||
letrec' name $ \addr ->
|
||||
eval xs <* makeNamespace name addr Nothing
|
||||
Rval <$> letrec' name (\addr ->
|
||||
value =<< (eval xs <* makeNamespace name addr Nothing))
|
||||
|
||||
data LowPrecedenceBoolean a
|
||||
= LowAnd !a !a
|
||||
@ -171,7 +171,7 @@ instance ToJSONFields1 LowPrecedenceBoolean
|
||||
|
||||
instance Evaluatable LowPrecedenceBoolean where
|
||||
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
|
||||
eval = go . fmap subtermValue where
|
||||
eval t = Rval <$> go (fmap subtermValue t) where
|
||||
go (LowAnd a b) = do
|
||||
cond <- a
|
||||
ifthenelse cond b (pure cond)
|
||||
|
||||
@ -152,7 +152,7 @@ instance Evaluatable Import where
|
||||
eval (Import symbols importPath) = do
|
||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
|
||||
modifyEnv (mergeEnvs (renamed importedEnv)) *> unit
|
||||
modifyEnv (mergeEnvs (renamed importedEnv)) *> (Rval <$> unit)
|
||||
where
|
||||
renamed importedEnv
|
||||
| Prologue.null symbols = importedEnv
|
||||
@ -171,7 +171,7 @@ instance Evaluatable JavaScriptRequire where
|
||||
eval (JavaScriptRequire aliasTerm importPath) = do
|
||||
modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions
|
||||
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
|
||||
evalRequire modulePath alias
|
||||
Rval <$> evalRequire modulePath alias
|
||||
|
||||
|
||||
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath }
|
||||
@ -187,7 +187,7 @@ instance Evaluatable QualifiedAliasedImport where
|
||||
eval (QualifiedAliasedImport aliasTerm importPath) = do
|
||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
|
||||
evalRequire modulePath alias
|
||||
Rval <$> evalRequire modulePath alias
|
||||
|
||||
newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -202,7 +202,7 @@ instance Evaluatable SideEffectImport where
|
||||
eval (SideEffectImport importPath) = do
|
||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||
void $ isolate (require modulePath)
|
||||
unit
|
||||
Rval <$> unit
|
||||
|
||||
|
||||
-- | Qualified Export declarations
|
||||
@ -220,7 +220,7 @@ instance Evaluatable QualifiedExport where
|
||||
-- Insert the aliases with no addresses.
|
||||
for_ exportSymbols $ \(name, alias) ->
|
||||
addExport name alias Nothing
|
||||
unit
|
||||
Rval <$> unit
|
||||
|
||||
|
||||
-- | Qualified Export declarations that export from another module.
|
||||
@ -241,7 +241,7 @@ instance Evaluatable QualifiedExportFrom where
|
||||
for_ exportSymbols $ \(name, alias) -> do
|
||||
let address = Env.lookup name importedEnv
|
||||
maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address
|
||||
unit
|
||||
Rval <$> unit
|
||||
|
||||
newtype DefaultExport a = DefaultExport { defaultExport :: a }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -262,7 +262,7 @@ instance Evaluatable DefaultExport where
|
||||
addExport name name Nothing
|
||||
void $ modifyEnv (Env.insert name addr)
|
||||
Nothing -> throwEvalError DefaultExportError
|
||||
unit
|
||||
Rval <$> unit
|
||||
|
||||
|
||||
-- | Lookup type for a type-level key in a typescript map.
|
||||
@ -539,7 +539,7 @@ instance Ord1 AmbientDeclaration where liftCompare = genericLiftCompare
|
||||
instance Show1 AmbientDeclaration where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable AmbientDeclaration where
|
||||
eval (AmbientDeclaration body) = subtermValue body
|
||||
eval (AmbientDeclaration body) = subtermRef body
|
||||
|
||||
data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, _enumDeclarationBody :: ![a] }
|
||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||
@ -757,8 +757,8 @@ instance ToJSONFields1 Module
|
||||
instance Evaluatable Module where
|
||||
eval (Module iden xs) = do
|
||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
|
||||
letrec' name $ \addr ->
|
||||
eval xs <* makeNamespace name addr Nothing
|
||||
Rval <$> letrec' name (\addr ->
|
||||
value =<< (eval xs <* makeNamespace name addr Nothing))
|
||||
|
||||
|
||||
|
||||
@ -774,8 +774,8 @@ instance ToJSONFields1 InternalModule
|
||||
instance Evaluatable InternalModule where
|
||||
eval (InternalModule iden xs) = do
|
||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
|
||||
letrec' name $ \addr ->
|
||||
eval xs <* makeNamespace name addr Nothing
|
||||
Rval <$> letrec' name (\addr ->
|
||||
value =<< (eval xs <* makeNamespace name addr Nothing))
|
||||
|
||||
instance Declarations a => Declarations (InternalModule a) where
|
||||
declaredName InternalModule{..} = declaredName internalModuleIdentifier
|
||||
@ -840,7 +840,7 @@ instance Evaluatable AbstractClass where
|
||||
void $ subtermValue classBody
|
||||
classEnv <- Env.head <$> getEnv
|
||||
klass name supers classEnv
|
||||
v <$ modifyEnv (Env.insert name addr)
|
||||
Rval <$> (v <$ modifyEnv (Env.insert name addr))
|
||||
|
||||
|
||||
data JsxElement a = JsxElement { _jsxOpeningElement :: !a, _jsxElements :: ![a], _jsxClosingElement :: !a }
|
||||
|
||||
@ -120,7 +120,7 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *
|
||||
FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
|
||||
|
||||
resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator location value (Resumable (Unspecialized value) ': effects) a -> Evaluator location value effects a
|
||||
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> hole)
|
||||
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> Rval hole)
|
||||
|
||||
resumingAddressError :: (AbstractHole value, Lower (Cell location value), Member Trace effects, Show location) => Evaluator location value (Resumable (AddressError location value) ': effects) a -> Evaluator location value effects a
|
||||
resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> show err) *> case err of
|
||||
|
||||
Loading…
Reference in New Issue
Block a user