1
1
mirror of https://github.com/github/semantic.git synced 2024-12-26 16:33:03 +03:00

Pair down to a single, new Evaluatable

This commit is contained in:
Timothy Clem 2018-02-23 11:11:13 -08:00
parent 4d090bb085
commit b9b3c1bedd
17 changed files with 351 additions and 815 deletions

View File

@ -15,13 +15,11 @@ library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: exposed-modules:
-- Analyses & term annotations -- Analyses & term annotations
Analysis.Abstract.Caching -- Analysis.Abstract.Caching
, Analysis.Abstract.Collecting -- , Analysis.Abstract.Collecting
, Analysis.Abstract.Dead -- , Analysis.Abstract.Dead
, Analysis.Abstract.Evaluating Analysis.Abstract.Evaluating
, Analysis.Abstract.Evaluating2 -- , Analysis.Abstract.Tracing
, Analysis.Abstract.Evaluating3
, Analysis.Abstract.Tracing
, Analysis.ConstructorName , Analysis.ConstructorName
, Analysis.CyclomaticComplexity , Analysis.CyclomaticComplexity
, Analysis.Decorator , Analysis.Decorator
@ -49,9 +47,7 @@ library
, Data.Abstract.Configuration , Data.Abstract.Configuration
, Data.Abstract.Environment , Data.Abstract.Environment
, Data.Abstract.Linker , Data.Abstract.Linker
, Data.Abstract.Eval , Data.Abstract.Evaluatable
, Data.Abstract.Eval2
, Data.Abstract.Eval3
, Data.Abstract.FreeVariables , Data.Abstract.FreeVariables
, Data.Abstract.Live , Data.Abstract.Live
, Data.Abstract.Store , Data.Abstract.Store

View File

@ -2,19 +2,14 @@
module Analysis.Abstract.Evaluating where module Analysis.Abstract.Evaluating where
import Control.Effect import Control.Effect
import Control.Monad.Effect hiding (run) import Control.Monad.Effect (Eff, Members)
import Control.Monad.Effect.Address
import Control.Monad.Effect.Fail import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State import Control.Monad.Effect.State
import Data.Abstract.Address import Control.Monad.Effect.Reader
import Data.Abstract.Environment
import Data.Abstract.Linker import Data.Abstract.Linker
import Data.Abstract.FreeVariables import Data.Abstract.Evaluatable
import Data.Abstract.Eval
import Data.Abstract.Store import Data.Abstract.Store
import Data.Abstract.Value import Data.Abstract.Value
import Data.Abstract.Live
import Data.Function (fix) import Data.Function (fix)
import Data.Functor.Foldable (Base, Recursive(..)) import Data.Functor.Foldable (Base, Recursive(..))
import qualified Data.Map as Map import qualified Data.Map as Map
@ -22,58 +17,47 @@ import Data.Semigroup
import Prelude hiding (fail) import Prelude hiding (fail)
import Data.Blob import Data.Blob
import System.FilePath.Posix import System.FilePath.Posix
import Control.Monad.Effect.Embedded
class Monad m => MonadLinker v m where
require :: FilePath -> m v
instance (b ~ Eff (Evaluating v)) => MonadLinker v b where
require name = do
linker <- ask
maybe (fail ("cannot find " <> show name)) runEvaluator (linkerLookup name linker)
-- | The effects necessary for concrete interpretation. -- | The effects necessary for concrete interpretation.
type Evaluating v type Evaluating v
= '[ Fail -- For 'MonadFail'. = '[ Fail
, State (Store (LocationFor v) v) -- For 'MonadStore'. , State (Store (LocationFor v) v)
, Reader (Environment (LocationFor v) v) -- For 'MonadEnv'. , State (EnvironmentFor v) -- Global (imperative) environment
, Reader (Live (LocationFor v) v) -- For 'MonadGC'. , Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
, Reader (Linker (Evaluator v)) -- For 'MonadLinker' , Reader (Linker (Evaluator v))
] ]
newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating v) v } newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating v) v }
-- | Require/import another file and return an Effect.
require :: forall v es. Members (Evaluating v) es => FilePath -> Eff es v
require name = do
linker <- ask @(Linker (Evaluator v))
maybe (fail ("cannot find " <> show name)) (raiseEmbedded . runEvaluator) (linkerLookup name linker)
-- | Evaluate a term to a value. -- | Evaluate a term to a value.
evaluate :: forall v term evaluate :: forall v term.
. ( Ord v ( Ord v
, Ord (Cell (LocationFor v) v) , Ord (LocationFor v)
, Semigroup (Cell (LocationFor v) v) , Evaluatable (Evaluating v) term v (Base term)
, Functor (Base term)
, Recursive term , Recursive term
, MonadAddress (LocationFor v) (Eff (Evaluating v))
, Eval term v (Eff (Evaluating v)) (Base term)
) )
=> term => term
-> Final (Evaluating v) v -> Final (Evaluating v) v
evaluate = run @(Evaluating v) . fix go pure evaluate = run @(Evaluating v) . fix (const step)
where go recur yield = eval recur yield . project
evaluates :: forall v term -- | Evaluate terms and an entry point to a value.
. ( Ord v evaluates :: forall v term.
, Ord (Cell (LocationFor v) v) ( Ord v
, Semigroup (Cell (LocationFor v) v) , Ord (LocationFor v)
, Functor (Base term) , Evaluatable (Evaluating v) term v (Base term)
, Recursive term , Recursive term
, AbstractValue v
, MonadAddress (LocationFor v) (Eff (Evaluating v))
, FreeVariables term
, Eval term v (Eff (Evaluating v)) (Base term)
) )
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
-> (Blob, term) -- Entrypoint -> (Blob, term) -- Entrypoint
-> Final (Evaluating v) v -> Final (Evaluating v) v
evaluates pairs = run @(Evaluating v) . fix go pure evaluates pairs = run @(Evaluating v) . fix go
where where
go recur yield (b@Blob{..}, t) = local (const (Linker (Map.fromList (map (toPathActionPair recur pure) pairs)))) $ go _ (Blob{..}, t) = local (const (Linker (Map.fromList (map toPathActionPair pairs)))) (step @v t)
eval (\ev term -> recur ev (b, term)) yield (project t) toPathActionPair (Blob{..}, t) = (dropExtensions blobPath, Evaluator (step @v t))
toPathActionPair recur yield (b@Blob{..}, t) = (dropExtensions blobPath, Evaluator (go recur yield (b, t)))

View File

@ -1,43 +0,0 @@
{-# LANGUAGE ConstraintKinds, DataKinds, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, MultiParamTypeClasses #-}
module Analysis.Abstract.Evaluating2 where
import Control.Effect
import Control.Monad.Effect hiding (run)
import Control.Monad.Effect.Address
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Address
import Data.Abstract.Environment
import Data.Abstract.Linker
import Data.Abstract.FreeVariables
import Data.Abstract.Eval2
import Data.Abstract.Store
import Data.Abstract.Value
import Data.Abstract.Live
import Data.Function (fix)
import Data.Functor.Foldable (Base, Recursive(..))
import qualified Data.Map as Map
import Data.Semigroup
import Prelude hiding (fail)
import Data.Blob
import System.FilePath.Posix
-- | The effects necessary for concrete interpretation.
type Evaluating v
= '[ Fail -- For 'MonadFail'.
, State (Store (LocationFor v) v) -- For 'MonadStore'.
, Reader (Environment (LocationFor v) v) -- Local environment
, State (Environment (LocationFor v) v) -- Global environment
]
-- | Evaluate a term to a value.
evaluate :: forall v term
. ( Ord v
, Ord (LocationFor v) -- For 'MonadStore'
, Recursive term
, Eval term v (Eff (Evaluating v)) (Base term)
)
=> term
-> Final (Evaluating v) v
evaluate = run @(Evaluating v) . fix (const step)

View File

@ -1,63 +0,0 @@
{-# LANGUAGE ConstraintKinds, DataKinds, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, MultiParamTypeClasses #-}
module Analysis.Abstract.Evaluating3 where
import Control.Effect
import Control.Monad.Effect (Eff, Members)
import Control.Monad.Effect.Fail
import Control.Monad.Effect.State
import Control.Monad.Effect.Reader
import Data.Abstract.Linker
import Data.Abstract.Eval3
import Data.Abstract.Store
import Data.Abstract.Value
import Data.Function (fix)
import Data.Functor.Foldable (Base, Recursive(..))
import qualified Data.Map as Map
import Data.Semigroup
import Prelude hiding (fail)
import Data.Blob
import System.FilePath.Posix
import Control.Monad.Effect.Embedded
-- | The effects necessary for concrete interpretation.
type Evaluating v
= '[ Fail
, State (Store (LocationFor v) v)
, State (EnvironmentFor v) -- Global (imperative) environment
, Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
, Reader (Linker (Evaluator v))
]
newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating v) v }
-- | Require/import another file and return an Effect.
require :: forall v es. Members (Evaluating v) es => FilePath -> Eff es v
require name = do
linker <- ask @(Linker (Evaluator v))
maybe (fail ("cannot find " <> show name)) (raiseEmbedded . runEvaluator) (linkerLookup name linker)
-- | Evaluate a term to a value.
evaluate :: forall v term.
( Ord v
, Ord (LocationFor v)
, Evaluatable (Evaluating v) term v (Base term)
, Recursive term
)
=> term
-> Final (Evaluating v) v
evaluate = run @(Evaluating v) . fix (const step)
-- | Evaluate terms and an entry point to a value.
evaluates :: forall v term.
( Ord v
, Ord (LocationFor v)
, Evaluatable (Evaluating v) term v (Base term)
, Recursive term
)
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
-> (Blob, term) -- Entrypoint
-> Final (Evaluating v) v
evaluates pairs = run @(Evaluating v) . fix go
where
go _ (Blob{..}, t) = local (const (Linker (Map.fromList (map toPathActionPair pairs)))) (step @v t)
toPathActionPair (Blob{..}, t) = (dropExtensions blobPath, Evaluator (step @v t))

View File

@ -1,10 +1,11 @@
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
module Control.Monad.Effect.Address where module Control.Monad.Effect.Address where
import Control.Applicative import Control.Applicative
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import Control.Monad.Effect.Store import Control.Monad.Effect (Eff)
import Control.Monad.Fail as Fail import Control.Monad.Effect.Fail
import Control.Monad.Effect.State
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
@ -13,55 +14,73 @@ import Data.Abstract.Value
import Data.Foldable (asum, toList) import Data.Foldable (asum, toList)
import Data.Pointed import Data.Pointed
import Data.Semigroup import Data.Semigroup
import Data.Union
import Prelude hiding (fail)
-- | 'Monad's offering 'alloc'ation and 'deref'erencing of 'Address'es. -- | 'Monad's offering 'alloc'ation and 'deref'erencing of 'Address'es.
class (Ord l, Pointed (Cell l), Monad m) => MonadAddress l m where class (Ord l, Pointed (Cell l)) => MonadAddress l es where
deref :: (MonadStore a m, MonadFail m, l ~ LocationFor a) => Address l a -> m a deref :: (Member (State (StoreFor a)) es , Member Fail es , l ~ LocationFor a)
=> Address l a -> Eff es a
alloc :: (MonadStore a m, l ~ LocationFor a) => Name -> m (Address l a) alloc :: (Member (State (StoreFor a)) es, l ~ LocationFor a)
=> Name -> Eff es (Address l a)
-- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address.
-- --
-- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers.
envLookupOrAlloc' :: envLookupOrAlloc' :: ( FreeVariables t
( FreeVariables t
, Semigroup (Cell (LocationFor a) a) , Semigroup (Cell (LocationFor a) a)
, MonadStore a m , Member (State (StoreFor a)) es
, MonadAddress (LocationFor a) m , MonadAddress (LocationFor a) es
) )
=> t -> Environment (LocationFor a) a -> a -> m (Name, Address (LocationFor a) a) => t
-> Environment (LocationFor a) a
-> a
-> Eff es (Name, Address (LocationFor a) a)
envLookupOrAlloc' term = let [name] = toList (freeVariables term) in envLookupOrAlloc' term = let [name] = toList (freeVariables term) in
envLookupOrAlloc name envLookupOrAlloc name
-- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address.
envLookupOrAlloc :: envLookupOrAlloc :: ( Semigroup (Cell (LocationFor a) a)
( Semigroup (Cell (LocationFor a) a) , Member (State (StoreFor a)) es
, MonadStore a m , MonadAddress (LocationFor a) es
, MonadAddress (LocationFor a) m
) )
=> Name -> Environment (LocationFor a) a -> a -> m (Name, Address (LocationFor a) a) => Name
-> Environment (LocationFor a) a
-> a
-> Eff es (Name, Address (LocationFor a) a)
envLookupOrAlloc name env v = do envLookupOrAlloc name env v = do
a <- maybe (alloc name) pure (envLookup name env) a <- maybe (alloc name) pure (envLookup name env)
assign a v assign a v
pure (name, a) pure (name, a)
-- | Write a value to the given 'Address' in the 'Store'.
assign :: ( Ord (LocationFor a)
, Semigroup (Cell (LocationFor a) a)
, Pointed (Cell (LocationFor a))
, Member (State (StoreFor a)) es
)
=> Address (LocationFor a) a
-> a
-> Eff es ()
assign address = modify . storeInsert address
-- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
uninitializedAddress :: Member Fail es => Eff es a
uninitializedAddress = fail "uninitialized address"
-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
instance Monad m => MonadAddress Precise m where instance MonadAddress Precise es where
deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap get . storeLookup
alloc _ = fmap allocPrecise getStore alloc _ = fmap allocPrecise get
where allocPrecise :: Store Precise a -> Address Precise a where allocPrecise :: Store Precise a -> Address Precise a
allocPrecise = Address . Precise . storeSize allocPrecise = Address . Precise . storeSize
-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
instance (Alternative m, Monad m) => MonadAddress Monovariant m where instance (Alternative (Eff es)) => MonadAddress Monovariant es where
deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup deref = asum . maybe [] (map pure . toList) <=< flip fmap get . storeLookup
alloc = pure . Address . Monovariant alloc = pure . Address . Monovariant
-- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
uninitializedAddress :: MonadFail m => m a
uninitializedAddress = Fail.fail "uninitialized address"

View File

@ -1,59 +0,0 @@
{-# LANGUAGE DefaultSignatures, MultiParamTypeClasses, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Eval
( Eval(..)
, MonadGC(..)
, MonadFail(..)
) where
import Control.Monad.Effect.Env
import Control.Monad.Effect.GC
import Control.Monad.Fail
import Data.Abstract.Environment
import Data.Abstract.FreeVariables
import Data.Abstract.Value
import Data.Functor.Classes
import Data.Proxy
import Data.Term
import Data.Union
import Prelude hiding (fail)
-- | The 'Eval' 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 Monad m => Eval term v m constr where
-- | Evaluate a term using an open-recursive evaluator for any child terms.
eval :: ((v -> m v) -> term -> m v) -- ^ The “recur” function. An open-recursive evaluator for child terms, taking a continuation representing the remainder of the childs scope. Syntax representing imperative sequences of statements should pass in a continuation evaluating the remaining statements. Syntax which introduces a lexical scope for variable bindings should pass 'pure'. Syntax which does not delimit variable bindings should pass the continuation that it itself was passed by its parent.
-> (v -> m v) -- ^ The “yield” function. A continuation representing the remainder of the current (imperative) scope. This allows each statement in an imperative sequence to affect the environment of later statements in the same scope, but without allowing such effects to escape their scope. For example, @do { x <- getX ; f x }@ binds @x@ in the local environment in the first statement s.t. the second can use it, but remains unbound outside of the @do@-block.
-> constr term -- ^ The current instruction in a program.
-> m v -- ^ A monadic computation producing the (abstract) evaluation of the current instruction.
default eval :: (MonadFail m, Show1 constr) => ((v -> m v) -> term -> m v) -> ((v -> m v) -> constr term -> m v)
eval _ _ expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""
-- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'.
instance (Monad m, Apply (Eval t v m) fs) => Eval t v m (Union fs) where
eval ev yield = apply (Proxy :: Proxy (Eval t v m)) (eval ev yield)
-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax.
instance (Monad m, Eval t v m s) => Eval t v m (TermF s a) where
eval ev yield In{..} = eval ev yield termFOut
-- | '[]' is treated as an imperative sequence of statements/declarations s.t.:
--
-- 1. Each statements effects on the store are accumulated;
-- 2. Each statement can affect the environment of later statements (e.g. by yielding under 'localEnv'); and
-- 3. Only the last statements return value is returned.
--
-- This also allows e.g. early returns to be implemented in the middle of a list, by means of a statement returning instead of yielding. Therefore, care must be taken by 'Eval' instances in general to yield and not simply return, or else they will unintentionally short-circuit control and skip the rest of the scope.
instance ( Monad m
, Ord (LocationFor v)
, MonadGC v m
, MonadEnv v m
, AbstractValue v
, FreeVariables t
)
=> Eval t v m [] where
eval _ yield [] = yield unit
eval ev yield [a] = ev pure a >>= yield
eval ev yield (a:as) = do
env <- askEnv :: m (Environment (LocationFor v) v)
extraRoots (envRoots env (freeVariables1 as)) (ev (const (eval ev pure as)) a) >>= yield

View File

@ -1,95 +0,0 @@
{-# LANGUAGE DefaultSignatures, MultiParamTypeClasses, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
module Data.Abstract.Eval2
( Eval(..)
, MonadGC(..)
, MonadFail(..)
, Recursive(..)
, Base
, EvalEnv(..)
) where
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Control.Monad.Effect.GC
import Control.Monad.Fail
import Data.Abstract.Environment
import Data.Abstract.FreeVariables
import Data.Abstract.Value
import Data.Functor.Classes
import Data.Proxy
import Data.Term
import Data.Union
import Data.Functor.Foldable (Base, Recursive(..), project)
import Prelude hiding (fail)
import Control.Monad.Effect hiding (run)
-- a local and global environment binding variable names to addresses.
class EvalEnv v m where
askEnv :: m (Environment (LocationFor v) v)
localEnv :: (Environment (LocationFor v) v -> Environment (LocationFor v) v) -> m v -> m v
modifyEnv :: (Environment (LocationFor v) v -> Environment (LocationFor v) v) -> m ()
getEnv :: m (Environment (LocationFor v) v)
step :: forall term. (Eval term v m (Base term), Recursive term) => term -> m v
instance ( Reader (Environment (LocationFor v) v) :< fs
, State (Environment (LocationFor v) v) :< fs
)
=> EvalEnv v (Eff fs) where
askEnv = ask
localEnv = local
modifyEnv f = get >>= put . f
getEnv = get
step = eval . project
-- | The 'Eval' 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 Monad m => Eval term v m constr where
eval :: constr term -> m v
default eval :: (MonadFail m, Show1 constr) => (constr term -> m v)
eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""
-- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'.
instance (Monad m, Apply (Eval t v m) fs) => Eval t v m (Union fs) where
eval = apply (Proxy :: Proxy (Eval t v m)) eval
-- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax.
instance (Monad m, Eval t v m s) => Eval t v m (TermF s a) where
eval In{..} = eval termFOut
-- | '[]' is treated as an imperative sequence of statements/declarations s.t.:
--
-- 1. Each statements effects on the store are accumulated;
-- 2. Each statement can affect the environment of later statements (e.g. by yielding under 'localEnv'); and
-- 3. Only the last statements return value is returned.
--
-- This also allows e.g. early returns to be implemented in the middle of a list, by means of a statement returning instead of yielding. Therefore, care must be taken by 'Eval' instances in general to yield and not simply return, or else they will unintentionally short-circuit control and skip the rest of the scope.
instance ( Monad m
, Ord (LocationFor v)
, AbstractValue v
, Recursive t
, FreeVariables t
, EvalEnv v m
, Eval t v m (Base t)
, Show (LocationFor v)
)
=> Eval t v m [] where
eval [] = pure unit -- Return unit value if this is an empty list of terms
eval [x] = step x -- Return the value for the last term
eval (x:xs) = do
_ <- step @v x -- Evaluate the head term
env <- getEnv @v -- Get the global environment after evaluation since
-- it might have been modified by the 'step'
-- evaluation above ^.
-- Finally, evaluate the rest of the terms, but do so by calculating a new
-- environment each time where the free variables in those terms are bound
-- to the global environment.
localEnv (const (bindEnv (freeVariables1 xs) env)) (eval xs)

View File

@ -1,8 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses, Rank2Types, GADTs, TypeOperators, DefaultSignatures, UndecidableInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses, Rank2Types, GADTs, TypeOperators, DefaultSignatures, UndecidableInstances, ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Data.Abstract.Eval3 module Data.Abstract.Evaluatable
( Evaluatable(..) ( Evaluatable(..)
, EnvironmentFor
, step , step
, Linker , Linker
, MonadGC(..) , MonadGC(..)
@ -28,7 +27,6 @@ import Prelude hiding (fail)
import Data.Union (Apply) import Data.Union (Apply)
import qualified Data.Union as U import qualified Data.Union as U
type EnvironmentFor v = Environment (LocationFor v) v
step :: forall v term es. (Evaluatable es term v (Base term), Recursive term) => term -> Eff es v step :: forall v term es. (Evaluatable es term v (Base term), Recursive term) => term -> Eff es v
step = eval . project step = eval . project

View File

@ -3,6 +3,7 @@ module Data.Abstract.Value where
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.Store
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Live import Data.Abstract.Live
import qualified Data.Abstract.Type as Type import qualified Data.Abstract.Type as Type
@ -78,6 +79,11 @@ instance Eq1 String where liftEq = genericLiftEq
instance Ord1 String where liftCompare = genericLiftCompare instance Ord1 String where liftCompare = genericLiftCompare
instance Show1 String where liftShowsPrec = genericLiftShowsPrec instance Show1 String where liftShowsPrec = genericLiftShowsPrec
-- | The environment for an abstract value type.
type EnvironmentFor v = Environment (LocationFor v) v
-- | The store for an abstract value type.
type StoreFor v = Store (LocationFor v) v
-- | The location type (the body of 'Address'es) which should be used for an abstract value type. -- | The location type (the body of 'Address'es) which should be used for an abstract value type.
type family LocationFor value :: * where type family LocationFor value :: * where

View File

@ -1,39 +1,30 @@
{-# LANGUAGE DeriveAnyClass, GADTs, DataKinds, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, TypeApplications #-} {-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, TypeApplications #-}
module Data.Syntax where module Data.Syntax where
import qualified Assigning.Assignment as Assignment
import Control.Applicative import Control.Applicative
import Control.Monad.Effect import Control.Monad.Effect
import Control.Monad.Effect.Address import Control.Monad.Effect.Address
import Control.Monad.Effect.Env
import Control.Monad.Effect.Store
import Control.Monad.Effect.State
import Control.Monad.Effect.Reader
import Control.Monad.Effect.Fail import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Control.Monad.Error.Class hiding (Error) import Control.Monad.Error.Class hiding (Error)
import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.Eval import Data.Abstract.Evaluatable
import qualified Data.Abstract.Eval2 as E2
import qualified Data.Abstract.Eval3 as E3
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Value (LocationFor, AbstractValue(..), Value) import Data.Abstract.Value (LocationFor, EnvironmentFor, StoreFor, AbstractValue(..), Value)
import qualified Data.Abstract.Value as Value
import qualified Data.Abstract.Type as Type
import Data.Align.Generic import Data.Align.Generic
import Data.AST import Data.AST
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.ByteString.Char8 (unpack) import Data.ByteString.Char8 (unpack)
import qualified Data.Error as Error
import Data.Foldable (asum, toList) import Data.Foldable (asum, toList)
import Data.Function ((&), on) import Data.Function ((&), on)
import Data.Functor.Classes.Generic
import Data.Ix import Data.Ix
import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import Data.Functor.Classes.Generic
import Data.Mergeable import Data.Mergeable
import Data.Pointed
import Data.Range import Data.Range
import Data.Record import Data.Record
import Data.Pointed
import Data.Semigroup import Data.Semigroup
import Data.Span import Data.Span
import Data.Term import Data.Term
@ -42,6 +33,10 @@ import Diffing.Algorithm hiding (Empty)
import GHC.Generics import GHC.Generics
import GHC.Stack import GHC.Stack
import Prelude hiding (fail) import Prelude hiding (fail)
import qualified Assigning.Assignment as Assignment
import qualified Data.Abstract.Type as Type
import qualified Data.Abstract.Value as Value
import qualified Data.Error as Error
-- Combinators -- Combinators
@ -134,30 +129,11 @@ instance Eq1 Identifier where liftEq = genericLiftEq
instance Ord1 Identifier where liftCompare = genericLiftCompare instance Ord1 Identifier where liftCompare = genericLiftCompare
instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
instance ( MonadAddress (LocationFor v) m instance ( MonadAddress (LocationFor v) es
, MonadEnv v m , Member Fail es
, MonadFail m , Member (Reader (EnvironmentFor v)) es
, MonadStore v m , Member (State (StoreFor v)) es
) => Eval t v m Identifier where ) => Evaluatable es t v Identifier where
eval _ yield (Identifier name) = do
env <- askEnv
maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env) >>= yield
instance ( MonadAddress (LocationFor v) m
-- , MonadEnv v m
, MonadFail m
, MonadStore v m
, E2.EvalEnv v m
) => E2.Eval t v m Identifier where
eval (Identifier name) = do
env <- E2.askEnv
maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env)
instance ( MonadAddress (LocationFor v) (Eff es)
, MonadStore v (Eff es)
, (Reader (E3.EnvironmentFor v) :< es)
, (Fail :< es)
) => E3.Evaluatable es t v Identifier where
eval (Identifier name) = do eval (Identifier name) = do
env <- ask env <- ask
maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env) maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env)
@ -172,74 +148,28 @@ instance Eq1 Program where liftEq = genericLiftEq
instance Ord1 Program where liftCompare = genericLiftCompare instance Ord1 Program where liftCompare = genericLiftCompare
instance Show1 Program where liftShowsPrec = genericLiftShowsPrec instance Show1 Program where liftShowsPrec = genericLiftShowsPrec
instance ( Monad m
, Ord l
, Show l
, Show t
, Semigroup (Cell l (Value l t))
, MonadEnv (Value l t) m
, MonadStore (Value l t) m
, MonadGC (Value l t) m
, MonadAddress l m
, FreeVariables t
)
=> Eval t (Value l t) m Program where
eval ev yield (Program xs) = eval' ev yield xs
where
eval' _ _ [] = injectAndYield unit
eval' ev _ [a] = ev pure a >>= injectAndYield
eval' ev yield (a:as) = do
env <- askEnv @(Value l t)
extraRoots (envAll env) (ev (const (eval' ev pure as)) a) >>= yield
injectAndYield :: Value l t -> m (Value l t)
injectAndYield val = do
env <- askEnv @(Value l t)
yield $ inj (Value.Interface val env)
instance ( Monad m
, Ord Type.Type
, MonadGC Type.Type m
, MonadEnv Type.Type m
, FreeVariables t
) => Eval t Type.Type m Program where
eval ev yield (Program xs) = eval ev yield xs
instance ( MonadFail m
, Ord (LocationFor v)
, AbstractValue v
, E2.Recursive t
, E2.Eval t v m (E2.Base t)
, FreeVariables t
, E2.EvalEnv v m
, Show (LocationFor v)
)
=> E2.Eval t v m Program where
eval (Program xs) = E2.eval xs
instance ( Ord (LocationFor (Value l t)) instance ( Ord (LocationFor (Value l t))
, Show (LocationFor (Value l t)) , Show (LocationFor (Value l t))
, E2.Recursive t , Recursive t
, E3.Evaluatable es t (Value l t) (E3.Base t) , Evaluatable es t (Value l t) (Base t)
, FreeVariables t , FreeVariables t
, Members '[ , Member Fail es
Fail, , Member (State (EnvironmentFor (Value l t))) es
State (E3.EnvironmentFor (Value l t)), , Member (Reader (EnvironmentFor (Value l t))) es
Reader (E3.EnvironmentFor (Value l t)) ] es
) )
=> E3.Evaluatable es t (Value l t) Program where => Evaluatable es t (Value l t) Program where
eval (Program xs) = eval' xs eval (Program xs) = eval' xs
where where
interface val = ask @(E3.EnvironmentFor (Value l t)) >>= pure . inj . Value.Interface val interface val = inj . Value.Interface val <$> ask @(EnvironmentFor (Value l t))
eval' [] = interface unit eval' [] = interface unit
eval' [x] = E3.step x >>= interface eval' [x] = step x >>= interface
eval' (x:xs) = do eval' (x:xs) = do
_ <- E3.step @(Value l t) x _ <- step @(Value l t) x
env <- get @(E3.EnvironmentFor (Value l t)) env <- get @(EnvironmentFor (Value l t))
local (envUnion env) (eval' xs) local (envUnion env) (eval' xs)
instance Member Fail es => E3.Evaluatable es t Type.Type Program where instance Member Fail es => Evaluatable es t Type.Type Program where
-- | An accessibility modifier, e.g. private, public, protected, etc. -- | An accessibility modifier, e.g. private, public, protected, etc.
newtype AccessibilityModifier a = AccessibilityModifier ByteString newtype AccessibilityModifier a = AccessibilityModifier ByteString
@ -250,7 +180,7 @@ instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
instance Show1 AccessibilityModifier where liftShowsPrec = genericLiftShowsPrec instance Show1 AccessibilityModifier where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for AccessibilityModifier -- TODO: Implement Eval instance for AccessibilityModifier
instance (MonadFail m) => Eval t v m AccessibilityModifier instance Member Fail es => Evaluatable es t v AccessibilityModifier
-- | Empty syntax, with essentially no-op semantics. -- | Empty syntax, with essentially no-op semantics.
-- --
@ -262,13 +192,7 @@ instance Eq1 Empty where liftEq _ _ _ = True
instance Ord1 Empty where liftCompare _ _ _ = EQ instance Ord1 Empty where liftCompare _ _ _ = EQ
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty" instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
instance (Monad m, AbstractValue v) => Eval t v m Empty where instance (AbstractValue v) => Evaluatable es t v Empty where
eval _ yield _ = yield unit
instance (Monad m, AbstractValue v) => E2.Eval t v m Empty where
eval _ = pure unit
instance (AbstractValue v) => E3.Evaluatable es t v Empty where
eval _ = pure unit eval _ = pure unit
@ -280,9 +204,7 @@ instance Eq1 Error where liftEq = genericLiftEq
instance Ord1 Error where liftCompare = genericLiftCompare instance Ord1 Error where liftCompare = genericLiftCompare
instance Show1 Error where liftShowsPrec = genericLiftShowsPrec instance Show1 Error where liftShowsPrec = genericLiftShowsPrec
instance (MonadFail m) => Eval t v m Error instance Member Fail es => Evaluatable es t v Error
instance (MonadFail m) => E2.Eval t v m Error
instance Member Fail es => E3.Evaluatable es t v Error
errorSyntax :: Error.Error String -> [a] -> Error a errorSyntax :: Error.Error String -> [a] -> Error a
errorSyntax Error.Error{..} = Error (ErrorStack (getCallStack callStack)) errorExpected errorActual errorSyntax Error.Error{..} = Error (ErrorStack (getCallStack callStack)) errorExpected errorActual
@ -318,5 +240,6 @@ instance Eq1 Context where liftEq = genericLiftEq
instance Ord1 Context where liftCompare = genericLiftCompare instance Ord1 Context where liftCompare = genericLiftCompare
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
instance (Monad m) => Eval t v m Context where instance (Evaluatable es t v (Base t), Recursive t)
eval ev yield Context{..} = ev yield contextSubject => Evaluatable es t v Context where
eval Context{..} = step contextSubject

View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-}
module Data.Syntax.Comment where module Data.Syntax.Comment where
import Data.Abstract.Eval import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Value as Value import Data.Abstract.Value as Value
import Data.Align.Generic import Data.Align.Generic
@ -19,8 +19,8 @@ instance Eq1 Comment where liftEq = genericLiftEq
instance Ord1 Comment where liftCompare = genericLiftCompare instance Ord1 Comment where liftCompare = genericLiftCompare
instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
instance (Monad m, AbstractValue v) => Eval t v m Comment where instance (AbstractValue v) => Evaluatable es t v Comment where
eval _ yield _ = yield unit eval _ = pure unit
-- TODO: nested comment types -- TODO: nested comment types
-- TODO: documentation comment types -- TODO: documentation comment types

View File

@ -1,38 +1,31 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, UndecidableInstances #-} {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, UndecidableInstances #-}
module Data.Syntax.Declaration where module Data.Syntax.Declaration where
import Analysis.Abstract.Evaluating
import Control.Applicative import Control.Applicative
import Control.Monad.Effect (Eff)
import Control.Monad.Effect.Address
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader import Control.Monad.Effect.Reader
import Control.Monad.Effect.State import Control.Monad.Effect.State
import Control.Monad.Effect.Address
import Control.Monad.Effect.Env
import Control.Monad.Effect.Fresh
import Control.Monad.Effect.Store
import Control.Monad.Effect (Eff)
import Control.Monad.Effect.Fail
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Analysis.Abstract.Evaluating import Data.Abstract.Evaluatable
import qualified Analysis.Abstract.Evaluating3 as E3
import Data.Abstract.Eval
import qualified Data.Abstract.Eval2 as E2
import qualified Data.Abstract.Eval3 as E3
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Type hiding (Type)
import qualified Data.Abstract.Value as Value
import qualified Data.Abstract.Type as Type
import qualified Data.ByteString.Char8 as BC
import Data.Abstract.Value import Data.Abstract.Value
import Data.Align.Generic import Data.Align.Generic
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Functor.Classes.Generic import Data.Functor.Classes.Generic
import Data.Mergeable import Data.Mergeable
import Data.Traversable
import Data.Semigroup import Data.Semigroup
import Data.Traversable
import Data.Union import Data.Union
import Diffing.Algorithm import Diffing.Algorithm
import GHC.Generics import GHC.Generics
import Prelude hiding (fail) import Prelude hiding (fail)
import qualified Data.Abstract.Type as Type
import qualified Data.Abstract.Value as Value
import qualified Data.ByteString.Char8 as BC
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a } data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@ -44,60 +37,19 @@ instance Eq1 Function where liftEq = genericLiftEq
instance Ord1 Function where liftCompare = genericLiftCompare instance Ord1 Function where liftCompare = genericLiftCompare
instance Show1 Function where liftShowsPrec = genericLiftShowsPrec instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
-- TODO: Do we need some distinct notion of a global environment?
-- TODO: Implement evaluation under the binder for the typechecking evaluator. -- TODO: Implement evaluation under the binder for the typechecking evaluator.
-- TODO: Filter the closed-over environment by the free variables in the term. -- TODO: Filter the closed-over environment by the free variables in the term.
instance ( Monad m -- TODO: How should we represent function types, where applicable?
, Ord l
, Semigroup (Cell l (Value l t))
, MonadEnv (Value l t) m
, MonadStore (Value l t) m
, MonadAddress l m
, FreeVariables t
) => Eval t (Value l t) m Function where
eval _ yield Function{..} = do
env <- askEnv @(Value l t)
let params = toList (foldMap freeVariables functionParameters)
let v = inj (Closure params functionBody env)
(name, a) <- envLookupOrAlloc' functionName env v
localEnv (envInsert name a) (yield v)
instance ( Alternative m
, Monad m
, MonadFresh m
, MonadEnv Type.Type m
, MonadStore Type.Type m
, FreeVariables t
)
=> Eval t Type.Type m Function where
eval recur yield Function{..} = do
env <- askEnv @Type.Type
let params = toList (foldMap freeVariables functionParameters)
tvars <- for params $ \name -> do
a <- alloc name
tvar <- Var <$> fresh
assign a tvar
pure (name, a, tvar)
outTy <- localEnv (const (foldr (\ (n, a, _) -> envInsert n a) env tvars)) (recur pure functionBody)
let tvars' = fmap (\(_, _, t) -> t) tvars
let v = Type.Product tvars' :-> outTy
(name, a) <- envLookupOrAlloc' functionName env v
localEnv (envInsert name a) (yield v)
instance ( FreeVariables t instance ( FreeVariables t
, Semigroup (Cell l (Value l t)) , Semigroup (Cell l (Value l t))
, MonadStore (Value l t) (Eff es) , MonadAddress l es
, MonadAddress l (Eff es) , Member (State (EnvironmentFor (Value l t))) es
, Member (State (E3.EnvironmentFor (Value l t))) es , Member (Reader (EnvironmentFor (Value l t))) es
, Member (Reader (E3.EnvironmentFor (Value l t))) es , Member (State (StoreFor (Value l t))) es
) => E3.Evaluatable es t (Value l t) Function where ) => Evaluatable es t (Value l t) Function where
eval Function{..} = do eval Function{..} = do
env <- ask @(E3.EnvironmentFor (Value l t)) env <- ask @(EnvironmentFor (Value l t))
let params = toList (freeVariables1 functionParameters) let params = toList (freeVariables1 functionParameters)
let v = inj (Closure params functionBody env) :: Value l t let v = inj (Closure params functionBody env) :: Value l t
@ -105,9 +57,33 @@ instance ( FreeVariables t
modify (envInsert name addr) modify (envInsert name addr)
pure v pure v
instance ( Member Fail es ) => E3.Evaluatable es t Type.Type Function -- TODO: Re-implement type checking with 'Evaluatable' approach.
instance Member Fail es => Evaluatable es t Type.Type Function
-- instance ( Alternative m
-- , Monad m
-- , MonadFresh m
-- , MonadEnv Type.Type m
-- , MonadStore Type.Type m
-- , FreeVariables t
-- )
-- => Eval t Type.Type m Function where
-- eval recur yield Function{..} = do
-- env <- askEnv @Type.Type
-- let params = toList (foldMap freeVariables functionParameters)
-- tvars <- for params $ \name -> do
-- a <- alloc name
-- tvar <- Var <$> fresh
-- assign a tvar
-- pure (name, a, tvar)
--
-- outTy <- localEnv (const (foldr (\ (n, a, _) -> envInsert n a) env tvars)) (recur pure functionBody)
-- let tvars' = fmap (\(_, _, t) -> t) tvars
-- let v = Type.Product tvars' :-> outTy
--
-- (name, a) <- envLookupOrAlloc' functionName env v
--
-- localEnv (envInsert name a) (yield v)
-- TODO: How should we represent function types, where applicable?
data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a } data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@ -119,38 +95,17 @@ instance Eq1 Method where liftEq = genericLiftEq
instance Ord1 Method where liftCompare = genericLiftCompare instance Ord1 Method where liftCompare = genericLiftCompare
instance Show1 Method where liftShowsPrec = genericLiftShowsPrec instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Method -- Evaluating a Method creates a closure and makes that value available in the
instance (MonadFail m) => Eval t v m Method
-- Evaluating a Function creates a closure and makes that value available in the
-- local environment. -- local environment.
instance ( Monad m
, FreeVariables t -- To get free variables from the function's parameters
, Semigroup (Cell l (Value l t)) -- envLookupOrAlloc'
, MonadStore (Value l t) m -- envLookupOrAlloc'
, MonadAddress l m -- envLookupOrAlloc'
, E2.EvalEnv (Value l t) m -- 'yield'
) => E2.Eval t (Value l t) m Method where
eval Method{..} = do
env <- E2.askEnv @(Value l t)
let params = toList (freeVariables1 methodParameters)
let v = inj (Closure params methodBody env) :: Value l t
(name, addr) <- envLookupOrAlloc' methodName env v
E2.modifyEnv (envInsert name addr)
pure v
instance MonadFail m => E2.Eval t Type.Type m Method
instance ( FreeVariables t -- To get free variables from the function's parameters instance ( FreeVariables t -- To get free variables from the function's parameters
, Semigroup (Cell l (Value l t)) -- envLookupOrAlloc' , Semigroup (Cell l (Value l t)) -- envLookupOrAlloc'
, MonadStore (Value l t) (Eff es) -- envLookupOrAlloc' , MonadAddress l es -- envLookupOrAlloc'
, MonadAddress l (Eff es) -- envLookupOrAlloc' , Member (State (EnvironmentFor (Value l t))) es
, Member (State (E3.EnvironmentFor (Value l t))) es , Member (Reader (EnvironmentFor (Value l t))) es
, Member (Reader (E3.EnvironmentFor (Value l t))) es , Member (State (StoreFor (Value l t))) es
) => E3.Evaluatable es t (Value l t) Method where ) => Evaluatable es t (Value l t) Method where
eval Method{..} = do eval Method{..} = do
env <- ask @(E3.EnvironmentFor (Value l t)) env <- ask @(EnvironmentFor (Value l t))
let params = toList (freeVariables1 methodParameters) let params = toList (freeVariables1 methodParameters)
let v = inj (Closure params methodBody env) :: Value l t let v = inj (Closure params methodBody env) :: Value l t
@ -158,7 +113,8 @@ instance ( FreeVariables t -- To get free variables from the func
modify (envInsert name addr) modify (envInsert name addr)
pure v pure v
instance ( Member Fail es ) => E3.Evaluatable es t Type.Type Method -- TODO: Implement Evaluatable instance for type checking
instance Member Fail es => Evaluatable es t Type.Type Method
-- | A method signature in TypeScript or a method spec in Go. -- | A method signature in TypeScript or a method spec in Go.
data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] } data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] }
@ -169,10 +125,10 @@ instance Ord1 MethodSignature where liftCompare = genericLiftCompare
instance Show1 MethodSignature where liftShowsPrec = genericLiftShowsPrec instance Show1 MethodSignature where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for MethodSignature -- TODO: Implement Eval instance for MethodSignature
instance (MonadFail m) => Eval t v m MethodSignature instance Member Fail es => Evaluatable es t v MethodSignature
data RequiredParameter a = RequiredParameter { requiredParameter :: !a } newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
instance Eq1 RequiredParameter where liftEq = genericLiftEq instance Eq1 RequiredParameter where liftEq = genericLiftEq
@ -180,10 +136,10 @@ instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for RequiredParameter -- TODO: Implement Eval instance for RequiredParameter
instance (MonadFail m) => Eval t v m RequiredParameter instance Member Fail es => Evaluatable es t v RequiredParameter
data OptionalParameter a = OptionalParameter { optionalParameter :: !a } newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
instance Eq1 OptionalParameter where liftEq = genericLiftEq instance Eq1 OptionalParameter where liftEq = genericLiftEq
@ -191,7 +147,7 @@ instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for OptionalParameter -- TODO: Implement Eval instance for OptionalParameter
instance (MonadFail m) => Eval t v m OptionalParameter instance Member Fail es => Evaluatable es t v OptionalParameter
-- TODO: Should we replace this with Function and differentiate by context? -- TODO: Should we replace this with Function and differentiate by context?
@ -206,7 +162,7 @@ instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for VariableDeclaration -- TODO: Implement Eval instance for VariableDeclaration
instance (MonadFail m) => Eval t v m VariableDeclaration instance Member Fail es => Evaluatable es t v VariableDeclaration
-- | A TypeScript/Java style interface declaration to implement. -- | A TypeScript/Java style interface declaration to implement.
@ -218,7 +174,7 @@ instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for InterfaceDeclaration -- TODO: Implement Eval instance for InterfaceDeclaration
instance (MonadFail m) => Eval t v m InterfaceDeclaration instance Member Fail es => Evaluatable es t v InterfaceDeclaration
-- | A public field definition such as a field definition in a JavaScript class. -- | A public field definition such as a field definition in a JavaScript class.
@ -230,7 +186,7 @@ instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for PublicFieldDefinition -- TODO: Implement Eval instance for PublicFieldDefinition
instance (MonadFail m) => Eval t v m PublicFieldDefinition instance Member Fail es => Evaluatable es t v PublicFieldDefinition
data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a } data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
@ -241,7 +197,7 @@ instance Ord1 Variable where liftCompare = genericLiftCompare
instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Variable -- TODO: Implement Eval instance for Variable
instance (MonadFail m) => Eval t v m Variable instance Member Fail es => Evaluatable es t v Variable
data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a } data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@ -254,7 +210,7 @@ instance Ord1 Class where liftCompare = genericLiftCompare
instance Show1 Class where liftShowsPrec = genericLiftShowsPrec instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Class -- TODO: Implement Eval instance for Class
instance (MonadFail m) => Eval t v m Class instance Member Fail es => Evaluatable es t v Class
data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] } data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] }
@ -265,7 +221,7 @@ instance Ord1 Module where liftCompare = genericLiftCompare
instance Show1 Module where liftShowsPrec = genericLiftShowsPrec instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Module -- TODO: Implement Eval instance for Module
instance (MonadFail m) => Eval t v m Module instance Member Fail es => Evaluatable es t v Module
-- | A decorator in Python -- | A decorator in Python
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a } data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
@ -276,7 +232,7 @@ instance Ord1 Decorator where liftCompare = genericLiftCompare
instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Decorator -- TODO: Implement Eval instance for Decorator
instance (MonadFail m) => Eval t v m Decorator instance Member Fail es => Evaluatable es t v Decorator
-- TODO: Generics, constraints. -- TODO: Generics, constraints.
@ -290,7 +246,7 @@ instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCo
instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Datatype -- TODO: Implement Eval instance for Datatype
instance (MonadFail m) => Eval t v m Data.Syntax.Declaration.Datatype instance Member Fail es => Evaluatable es t v Data.Syntax.Declaration.Datatype
-- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift. -- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
@ -302,7 +258,7 @@ instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLif
instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Constructor -- TODO: Implement Eval instance for Constructor
instance (MonadFail m) => Eval t v m Data.Syntax.Declaration.Constructor instance Member Fail es => Evaluatable es t v Data.Syntax.Declaration.Constructor
-- | Comprehension (e.g. ((a for b in c if a()) in Python) -- | Comprehension (e.g. ((a for b in c if a()) in Python)
@ -314,7 +270,7 @@ instance Ord1 Comprehension where liftCompare = genericLiftCompare
instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Comprehension -- TODO: Implement Eval instance for Comprehension
instance (MonadFail m) => Eval t v m Comprehension instance Member Fail es => Evaluatable es t v Comprehension
-- | Import declarations. -- | Import declarations.
data Import a = Import { importFrom :: !a, importAlias :: !a, importSymbols :: ![a] } data Import a = Import { importFrom :: !a, importAlias :: !a, importSymbols :: ![a] }
@ -324,41 +280,16 @@ instance Eq1 Import where liftEq = genericLiftEq
instance Ord1 Import where liftCompare = genericLiftCompare instance Ord1 Import where liftCompare = genericLiftCompare
instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance ( Monad m
, Show l
, Show t
, MonadFail m
, MonadLinker (Value l t) m
, MonadEnv (Value l t) m
, FreeVariables t
)
=> Eval t (Value l t) m Import where
eval _ yield (Import from _ _) = do
let [name] = toList (freeVariables from)
interface <- require (BC.unpack name)
Interface _ env <- maybe
(fail ("expected an interface, but got: " <> show interface))
pure
(prj interface :: Maybe (Value.Interface l t))
localEnv (envUnion env) (yield interface)
instance MonadFail m => Eval t Type.Type m Import
instance (MonadFail m) => E2.Eval t v m Import
instance ( Show l instance ( Show l
, Show t , Show t
, Members (E3.Evaluating (Value l t)) es , Members (Evaluating (Value l t)) es
, FreeVariables t , FreeVariables t
) )
=> E3.Evaluatable es t (Value l t) Import where => Evaluatable es t (Value l t) Import where
eval (Import from _ _) = do eval (Import from _ _) = do
let [name] = toList (freeVariables from) let [name] = toList (freeVariables from)
interface <- E3.require (BC.unpack name) interface <- require (BC.unpack name)
-- TODO: Consider returning the value instead of the interface. -- TODO: Consider returning the value instead of the interface.
Interface _ env <- maybe Interface _ env <- maybe
(fail ("expected an interface, but got: " <> show interface)) (fail ("expected an interface, but got: " <> show interface))
@ -368,7 +299,7 @@ instance ( Show l
modify (envUnion env) modify (envUnion env)
pure interface pure interface
-- --
instance Member Fail es => E3.Evaluatable es t Type.Type Import instance Member Fail es => Evaluatable es t Type.Type Import
-- | An imported symbol -- | An imported symbol
@ -380,7 +311,7 @@ instance Ord1 ImportSymbol where liftCompare = genericLiftCompare
instance Show1 ImportSymbol where liftShowsPrec = genericLiftShowsPrec instance Show1 ImportSymbol where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for ImportSymbol -- TODO: Implement Eval instance for ImportSymbol
instance (MonadFail m) => Eval t v m ImportSymbol instance Member Fail es => Evaluatable es t v ImportSymbol
-- | A declared type (e.g. `a []int` in Go). -- | A declared type (e.g. `a []int` in Go).
@ -392,7 +323,7 @@ instance Ord1 Type where liftCompare = genericLiftCompare
instance Show1 Type where liftShowsPrec = genericLiftShowsPrec instance Show1 Type where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Type -- TODO: Implement Eval instance for Type
instance (MonadFail m) => Eval t v m Type instance Member Fail es => Evaluatable es t v Type
-- | Type alias declarations in Javascript/Haskell, etc. -- | Type alias declarations in Javascript/Haskell, etc.
@ -404,4 +335,4 @@ instance Ord1 TypeAlias where liftCompare = genericLiftCompare
instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for TypeAlias -- TODO: Implement Eval instance for TypeAlias
instance (MonadFail m) => Eval t v m TypeAlias instance Member Fail es => Evaluatable es t v TypeAlias

View File

@ -1,32 +1,24 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, TypeApplications #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
module Data.Syntax.Expression where module Data.Syntax.Expression where
import Data.Proxy
import Control.Monad.Effect import Control.Monad.Effect
import Control.Monad.Effect.State
import Control.Monad.Effect.Reader
import Control.Monad.Effect.Address import Control.Monad.Effect.Address
import Control.Monad.Effect.Env
import Control.Monad.Effect.Fresh
import Control.Monad.Effect.Store
import Control.Monad.Effect.Fail import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.Eval import Data.Abstract.Evaluatable
import qualified Data.Abstract.Eval2 as E2
import qualified Data.Abstract.Eval3 as E3
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Type as Type import Data.Abstract.Type as Type
import Data.Abstract.Value (Value, Closure(..)) import Data.Abstract.Value (Value, Closure(..), LocationFor, EnvironmentFor, StoreFor)
import Data.Maybe
import Data.Union
import Data.Semigroup
import Data.Traversable
import Data.Align.Generic import Data.Align.Generic
import Data.Functor.Classes.Generic import Data.Functor.Classes.Generic
import Data.Maybe
import Data.Mergeable import Data.Mergeable
import Data.Semigroup
import Data.Traversable
import Data.Union
import Diffing.Algorithm import Diffing.Algorithm
import GHC.Generics import GHC.Generics
import Prelude hiding (fail) import Prelude hiding (fail)
@ -39,82 +31,44 @@ instance Eq1 Call where liftEq = genericLiftEq
instance Ord1 Call where liftCompare = genericLiftCompare instance Ord1 Call where liftCompare = genericLiftCompare
instance Show1 Call where liftShowsPrec = genericLiftShowsPrec instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
instance ( Ord l instance ( Ord l
, MonadFail m , Semigroup (Cell l (Value l t)) -- 'assign'
, Semigroup (Cell l (Value l t)) , MonadAddress l es -- 'alloc'
, MonadEnv (Value l t) m , Member Fail es
, MonadStore (Value l t) m , Member (State (EnvironmentFor (Value l t))) es
, MonadAddress l m , Member (Reader (EnvironmentFor (Value l t))) es
) , Member (State (StoreFor (Value l t))) es
=> Eval t (Value l t) m Call where , Evaluatable es t (Value l t) (Base t)
eval recur yield Call{..} = do , Recursive t
closure <- recur pure callFunction ) => Evaluatable es t (Value l t) Call where
eval Call{..} = do
closure <- step @(Value l t) callFunction
Closure names body env <- maybe (fail "expected a closure") pure (prj closure :: Maybe (Closure l t)) Closure names body env <- maybe (fail "expected a closure") pure (prj closure :: Maybe (Closure l t))
bindings <- for (zip names callParams) $ \(name, param) -> do bindings <- for (zip names callParams) $ \(name, param) -> do
v <- recur pure param v <- step param
a <- alloc name a <- alloc name
assign a v assign a v
pure (name, a) pure (name, a)
localEnv (const (foldr (uncurry envInsert) env bindings)) (recur pure body) >>= yield
local (const (foldr (uncurry envInsert) env bindings)) (step body)
-- TODO: Implement type checking for Call
instance Member Fail es => Evaluatable es t Type.Type Call
-- TODO: extraRoots for evalCollect -- TODO: extraRoots for evalCollect
instance ( MonadFail m -- instance ( MonadFail m
, MonadFresh m -- , MonadFresh m
, MonadGC Type m -- , MonadGC Type m
, MonadEnv Type m -- , MonadEnv Type m
, FreeVariables t -- , FreeVariables t
) -- )
=> Eval t Type m Call where -- => Eval t Type m Call where
eval recur yield Call{..} = do -- eval recur yield Call{..} = do
opTy <- recur pure callFunction -- opTy <- recur pure callFunction
tvar <- fresh -- tvar <- fresh
inTys <- traverse (recur pure) callParams -- inTys <- traverse (recur pure) callParams
_ :-> outTy <- opTy `unify` (Type.Product inTys :-> Var tvar) -- _ :-> outTy <- opTy `unify` (Type.Product inTys :-> Var tvar)
yield outTy -- yield outTy
instance ( Ord l
, MonadFail m
, Semigroup (Cell l (Value l t)) -- 'assign'
, MonadStore (Value l t) m -- 'alloc'
, MonadAddress l m -- 'alloc'
, E2.EvalEnv (Value l t) m -- 'yield'
, E2.Recursive t
, E2.Eval t (Value l t) m (E2.Base t)
)
=> E2.Eval t (Value l t) m Call where
eval Call{..} = do
closure <- E2.step @(Value l t) callFunction
Closure names body env <- maybe (fail "expected a closure") pure (prj closure :: Maybe (Closure l t))
bindings <- for (zip names callParams) $ \(name, param) -> do
v <- E2.step @(Value l t) param
a <- alloc name
assign a v
pure (name, a)
E2.localEnv (const (foldr (uncurry envInsert) env bindings)) (E2.step body)
instance ( Ord l
, Semigroup (Cell l (Value l t)) -- 'assign'
, MonadStore (Value l t) (Eff es) -- 'alloc'
, MonadAddress l (Eff es) -- 'alloc'
, Members '[
State (E3.EnvironmentFor (Value l t))
, Reader (E3.EnvironmentFor (Value l t))
, Fail
] es -- Env and EnvironmentFor
, E2.Recursive t
, E3.Evaluatable es t (Value l t) (E3.Base t)
) => E3.Evaluatable es t (Value l t) Call where
eval Call{..} = do
closure <- E3.step @(Value l t) callFunction
Closure names body env <- maybe (fail "expected a closure") pure (prj closure :: Maybe (Closure l t))
bindings <- for (zip names callParams) $ \(name, param) -> do
v <- E3.step param
a <- alloc name
assign a v
pure (name, a)
local (const (foldr (uncurry envInsert) env bindings)) (E3.step body)
data Comparison a data Comparison a
= LessThan !a !a = LessThan !a !a
@ -130,7 +84,7 @@ instance Ord1 Comparison where liftCompare = genericLiftCompare
instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Comparison -- TODO: Implement Eval instance for Comparison
instance (MonadFail m) => Eval t v m Comparison instance Member Fail es => Evaluatable es t v Comparison
-- | Binary arithmetic operators. -- | Binary arithmetic operators.
@ -149,7 +103,7 @@ instance Ord1 Arithmetic where liftCompare = genericLiftCompare
instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Arithmetic -- TODO: Implement Eval instance for Arithmetic
instance (MonadFail m) => Eval t v m Arithmetic instance Member Fail es => Evaluatable es t v Arithmetic
-- | Boolean operators. -- | Boolean operators.
@ -165,7 +119,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Boolean -- TODO: Implement Eval instance for Boolean
instance (MonadFail m) => Eval t v m Boolean instance Member Fail es => Evaluatable es t v Boolean
-- | Javascript delete operator -- | Javascript delete operator
@ -177,7 +131,7 @@ instance Ord1 Delete where liftCompare = genericLiftCompare
instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Delete -- TODO: Implement Eval instance for Delete
instance (MonadFail m) => Eval t v m Delete instance Member Fail es => Evaluatable es t v Delete
-- | A sequence expression such as Javascript or C's comma operator. -- | A sequence expression such as Javascript or C's comma operator.
@ -189,7 +143,7 @@ instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for SequenceExpression -- TODO: Implement Eval instance for SequenceExpression
instance (MonadFail m) => Eval t v m SequenceExpression instance Member Fail es => Evaluatable es t v SequenceExpression
-- | Javascript void operator -- | Javascript void operator
@ -201,7 +155,7 @@ instance Ord1 Void where liftCompare = genericLiftCompare
instance Show1 Void where liftShowsPrec = genericLiftShowsPrec instance Show1 Void where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Void -- TODO: Implement Eval instance for Void
instance (MonadFail m) => Eval t v m Void instance Member Fail es => Evaluatable es t v Void
-- | Javascript typeof operator -- | Javascript typeof operator
@ -213,7 +167,7 @@ instance Ord1 Typeof where liftCompare = genericLiftCompare
instance Show1 Typeof where liftShowsPrec = genericLiftShowsPrec instance Show1 Typeof where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Typeof -- TODO: Implement Eval instance for Typeof
instance (MonadFail m) => Eval t v m Typeof instance Member Fail es => Evaluatable es t v Typeof
-- | Bitwise operators. -- | Bitwise operators.
@ -232,7 +186,7 @@ instance Ord1 Bitwise where liftCompare = genericLiftCompare
instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Bitwise -- TODO: Implement Eval instance for Bitwise
instance (MonadFail m) => Eval t v m Bitwise instance Member Fail es => Evaluatable es t v Bitwise
-- | Member Access (e.g. a.b) -- | Member Access (e.g. a.b)
@ -245,7 +199,7 @@ instance Ord1 MemberAccess where liftCompare = genericLiftCompare
instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for MemberAccess -- TODO: Implement Eval instance for MemberAccess
instance (MonadFail m) => Eval t v m MemberAccess instance Member Fail es => Evaluatable es t v MemberAccess
-- | Subscript (e.g a[1]) -- | Subscript (e.g a[1])
@ -259,7 +213,7 @@ instance Ord1 Subscript where liftCompare = genericLiftCompare
instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Subscript -- TODO: Implement Eval instance for Subscript
instance (MonadFail m) => Eval t v m Subscript instance Member Fail es => Evaluatable es t v Subscript
-- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop)) -- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))
@ -271,7 +225,7 @@ instance Ord1 Enumeration where liftCompare = genericLiftCompare
instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Enumeration -- TODO: Implement Eval instance for Enumeration
instance (MonadFail m) => Eval t v m Enumeration instance Member Fail es => Evaluatable es t v Enumeration
-- | InstanceOf (e.g. a instanceof b in JavaScript -- | InstanceOf (e.g. a instanceof b in JavaScript
@ -283,7 +237,7 @@ instance Ord1 InstanceOf where liftCompare = genericLiftCompare
instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for InstanceOf -- TODO: Implement Eval instance for InstanceOf
instance (MonadFail m) => Eval t v m InstanceOf instance Member Fail es => Evaluatable es t v InstanceOf
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++) -- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
@ -295,7 +249,7 @@ instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for ScopeResolution -- TODO: Implement Eval instance for ScopeResolution
instance (MonadFail m) => Eval t v m ScopeResolution instance Member Fail es => Evaluatable es t v ScopeResolution
-- | A non-null expression such as Typescript or Swift's ! expression. -- | A non-null expression such as Typescript or Swift's ! expression.
@ -307,7 +261,7 @@ instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
instance Show1 NonNullExpression where liftShowsPrec = genericLiftShowsPrec instance Show1 NonNullExpression where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for NonNullExpression -- TODO: Implement Eval instance for NonNullExpression
instance (MonadFail m) => Eval t v m NonNullExpression instance Member Fail es => Evaluatable es t v NonNullExpression
-- | An await expression in Javascript or C#. -- | An await expression in Javascript or C#.
@ -319,7 +273,7 @@ instance Ord1 Await where liftCompare = genericLiftCompare
instance Show1 Await where liftShowsPrec = genericLiftShowsPrec instance Show1 Await where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Await -- TODO: Implement Eval instance for Await
instance (MonadFail m) => Eval t v m Await instance Member Fail es => Evaluatable es t v Await
-- | An object constructor call in Javascript, Java, etc. -- | An object constructor call in Javascript, Java, etc.
@ -331,7 +285,7 @@ instance Ord1 New where liftCompare = genericLiftCompare
instance Show1 New where liftShowsPrec = genericLiftShowsPrec instance Show1 New where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for New -- TODO: Implement Eval instance for New
instance (MonadFail m) => Eval t v m New instance Member Fail es => Evaluatable es t v New
-- | A cast expression to a specified type. -- | A cast expression to a specified type.
@ -343,4 +297,4 @@ instance Ord1 Cast where liftCompare = genericLiftCompare
instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Cast -- TODO: Implement Eval instance for Cast
instance (MonadFail m) => Eval t v m Cast instance Member Fail es => Evaluatable es t v Cast

View File

@ -1,17 +1,17 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses #-} {-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses #-}
module Data.Syntax.Literal where module Data.Syntax.Literal where
import Data.Abstract.Eval import Control.Monad.Effect.Fail
import qualified Data.Abstract.Eval2 as E2 import Data.Abstract.Evaluatable
import qualified Data.Abstract.Eval3 as E3
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Value (AbstractValue(..)) import Data.Abstract.Value (AbstractValue(..))
import Data.Align.Generic import Data.Align.Generic
import Data.Maybe
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.ByteString.Char8 (readInteger) import Data.ByteString.Char8 (readInteger)
import Data.Functor.Classes.Generic import Data.Functor.Classes.Generic
import Data.Maybe
import Data.Mergeable import Data.Mergeable
import Data.Union
import Diffing.Algorithm import Diffing.Algorithm
import GHC.Generics import GHC.Generics
import Prelude import Prelude
@ -31,8 +31,8 @@ instance Eq1 Boolean where liftEq = genericLiftEq
instance Ord1 Boolean where liftCompare = genericLiftCompare instance Ord1 Boolean where liftCompare = genericLiftCompare
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
instance (Monad m, AbstractValue v) => Eval t v m Boolean where instance AbstractValue v => Evaluatable es t v Boolean where
eval _ yield (Boolean x) = yield (boolean x) eval (Boolean x) = pure (boolean x)
-- Numeric -- Numeric
@ -45,17 +45,7 @@ instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec
instance (Monad m, AbstractValue v) => Eval t v m Data.Syntax.Literal.Integer where instance AbstractValue v => Evaluatable es t v Data.Syntax.Literal.Integer where
eval _ yield (Data.Syntax.Literal.Integer x) = yield (integer (maybe 0 fst (readInteger x)))
instance ( Monad m
, AbstractValue v
)
=> E2.Eval t v m Data.Syntax.Literal.Integer where
eval (Data.Syntax.Literal.Integer x) = pure (integer (maybe 0 fst (readInteger x)))
instance (AbstractValue v) =>
E3.Evaluatable es t v Data.Syntax.Literal.Integer where
-- TODO: This instance probably shouldn't have readInteger? -- TODO: This instance probably shouldn't have readInteger?
eval (Data.Syntax.Literal.Integer x) = pure (integer (maybe 0 fst (readInteger x))) eval (Data.Syntax.Literal.Integer x) = pure (integer (maybe 0 fst (readInteger x)))
@ -73,7 +63,7 @@ instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Float -- TODO: Implement Eval instance for Float
instance (MonadFail m) => Eval t v m Data.Syntax.Literal.Float instance Member Fail es => Evaluatable es t v Data.Syntax.Literal.Float
-- Rational literals e.g. `2/3r` -- Rational literals e.g. `2/3r`
@ -85,7 +75,7 @@ instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompar
instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Rational -- TODO: Implement Eval instance for Rational
instance (MonadFail m) => Eval t v m Data.Syntax.Literal.Rational instance Member Fail es => Evaluatable es t v Data.Syntax.Literal.Rational
-- Complex literals e.g. `3 + 2i` -- Complex literals e.g. `3 + 2i`
@ -97,7 +87,7 @@ instance Ord1 Data.Syntax.Literal.Complex where liftCompare = genericLiftCompare
instance Show1 Data.Syntax.Literal.Complex where liftShowsPrec = genericLiftShowsPrec instance Show1 Data.Syntax.Literal.Complex where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Complex -- TODO: Implement Eval instance for Complex
instance (MonadFail m) => Eval t v m Complex instance Member Fail es => Evaluatable es t v Complex
-- Strings, symbols -- Strings, symbols
@ -111,7 +101,7 @@ instance Show1 Data.Syntax.Literal.String where liftShowsPrec = genericLiftShows
-- TODO: Should string literal bodies include escapes too? -- TODO: Should string literal bodies include escapes too?
-- TODO: Implement Eval instance for String -- TODO: Implement Eval instance for String
instance (MonadFail m) => Eval t v m Data.Syntax.Literal.String instance Member Fail es => Evaluatable es t v Data.Syntax.Literal.String
-- | An interpolation element within a string literal. -- | An interpolation element within a string literal.
@ -123,7 +113,7 @@ instance Ord1 InterpolationElement where liftCompare = genericLiftCompare
instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for InterpolationElement -- TODO: Implement Eval instance for InterpolationElement
instance (MonadFail m) => Eval t v m InterpolationElement instance Member Fail es => Evaluatable es t v InterpolationElement
-- | A sequence of textual contents within a string literal. -- | A sequence of textual contents within a string literal.
@ -134,8 +124,8 @@ instance Eq1 TextElement where liftEq = genericLiftEq
instance Ord1 TextElement where liftCompare = genericLiftCompare instance Ord1 TextElement where liftCompare = genericLiftCompare
instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
instance (Monad m, AbstractValue v) => Eval t v m TextElement where instance AbstractValue v => Evaluatable es t v TextElement where
eval _ yield (TextElement x) = yield (string x) eval (TextElement x) = pure (string x)
data Null a = Null data Null a = Null
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@ -145,7 +135,7 @@ instance Ord1 Null where liftCompare = genericLiftCompare
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Null -- TODO: Implement Eval instance for Null
instance (MonadFail m) => Eval t v m Null instance Member Fail es => Evaluatable es t v Null
newtype Symbol a = Symbol { symbolContent :: ByteString } newtype Symbol a = Symbol { symbolContent :: ByteString }
@ -156,7 +146,7 @@ instance Ord1 Symbol where liftCompare = genericLiftCompare
instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Symbol -- TODO: Implement Eval instance for Symbol
instance (MonadFail m) => Eval t v m Symbol instance Member Fail es => Evaluatable es t v Symbol
newtype Regex a = Regex { regexContent :: ByteString } newtype Regex a = Regex { regexContent :: ByteString }
@ -170,7 +160,7 @@ instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec
-- TODO: Character literals. -- TODO: Character literals.
-- TODO: Implement Eval instance for Regex -- TODO: Implement Eval instance for Regex
instance (MonadFail m) => Eval t v m Regex instance Member Fail es => Evaluatable es t v Regex
-- Collections -- Collections
@ -183,7 +173,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Array -- TODO: Implement Eval instance for Array
instance (MonadFail m) => Eval t v m Array instance Member Fail es => Evaluatable es t v Array
newtype Hash a = Hash { hashElements :: [a] } newtype Hash a = Hash { hashElements :: [a] }
@ -194,7 +184,7 @@ instance Ord1 Hash where liftCompare = genericLiftCompare
instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Hash -- TODO: Implement Eval instance for Hash
instance (MonadFail m) => Eval t v m Hash instance Member Fail es => Evaluatable es t v Hash
data KeyValue a = KeyValue { key :: !a, value :: !a } data KeyValue a = KeyValue { key :: !a, value :: !a }
@ -205,7 +195,7 @@ instance Ord1 KeyValue where liftCompare = genericLiftCompare
instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for KeyValue -- TODO: Implement Eval instance for KeyValue
instance (MonadFail m) => Eval t v m KeyValue instance Member Fail es => Evaluatable es t v KeyValue
newtype Tuple a = Tuple { tupleContents :: [a] } newtype Tuple a = Tuple { tupleContents :: [a] }
@ -216,7 +206,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Tuple -- TODO: Implement Eval instance for Tuple
instance (MonadFail m) => Eval t v m Tuple instance Member Fail es => Evaluatable es t v Tuple
newtype Set a = Set { setElements :: [a] } newtype Set a = Set { setElements :: [a] }
@ -227,7 +217,7 @@ instance Ord1 Set where liftCompare = genericLiftCompare
instance Show1 Set where liftShowsPrec = genericLiftShowsPrec instance Show1 Set where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Set -- TODO: Implement Eval instance for Set
instance (MonadFail m) => Eval t v m Set instance Member Fail es => Evaluatable es t v Set
-- Pointers -- Pointers
@ -241,7 +231,7 @@ instance Ord1 Pointer where liftCompare = genericLiftCompare
instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Pointer -- TODO: Implement Eval instance for Pointer
instance (MonadFail m) => Eval t v m Pointer instance Member Fail es => Evaluatable es t v Pointer
-- | A reference to a pointer's address (e.g. &pointer in Go) -- | A reference to a pointer's address (e.g. &pointer in Go)
@ -253,7 +243,7 @@ instance Ord1 Reference where liftCompare = genericLiftCompare
instance Show1 Reference where liftShowsPrec = genericLiftShowsPrec instance Show1 Reference where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Reference -- TODO: Implement Eval instance for Reference
instance (MonadFail m) => Eval t v m Reference instance Member Fail es => Evaluatable es t v Reference
-- TODO: Object literals as distinct from hash literals? Or coalesce object/hash literals into “key-value literals”? -- TODO: Object literals as distinct from hash literals? Or coalesce object/hash literals into “key-value literals”?
-- TODO: Function literals (lambdas, procs, anonymous functions, what have you). -- TODO: Function literals (lambdas, procs, anonymous functions, what have you).

View File

@ -1,23 +1,24 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
module Data.Syntax.Statement where module Data.Syntax.Statement where
import Control.Monad.Effect (Eff)
import Control.Monad.Effect.Address import Control.Monad.Effect.Address
import Control.Monad.Effect.Env
import Control.Monad.Effect.Store
import Control.Monad.Effect.Fail import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Address import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.Eval import Data.Abstract.Store
import qualified Data.Abstract.Eval3 as E3 import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Value import Data.Abstract.Value
import Data.Semigroup
import Data.Align.Generic import Data.Align.Generic
import Data.Functor.Classes.Generic import Data.Functor.Classes.Generic
import Data.Mergeable import Data.Mergeable
import Data.Semigroup
import Data.Union
import Diffing.Algorithm import Diffing.Algorithm
import GHC.Generics import GHC.Generics
import Data.Union
-- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted. -- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a } data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
@ -28,7 +29,7 @@ instance Ord1 If where liftCompare = genericLiftCompare
instance Show1 If where liftShowsPrec = genericLiftShowsPrec instance Show1 If where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for If -- TODO: Implement Eval instance for If
instance (MonadFail m) => Eval t v m If instance Member Fail es => Evaluatable es t v If
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python. -- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
@ -40,7 +41,7 @@ instance Ord1 Else where liftCompare = genericLiftCompare
instance Show1 Else where liftShowsPrec = genericLiftShowsPrec instance Show1 Else where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Else -- TODO: Implement Eval instance for Else
instance (MonadFail m) => Eval t v m Else instance Member Fail es => Evaluatable es t v Else
-- TODO: Alternative definition would flatten if/else if/else chains: data If a = If ![(a, a)] !(Maybe a) -- TODO: Alternative definition would flatten if/else if/else chains: data If a = If ![(a, a)] !(Maybe a)
@ -53,7 +54,7 @@ instance Ord1 Goto where liftCompare = genericLiftCompare
instance Show1 Goto where liftShowsPrec = genericLiftShowsPrec instance Show1 Goto where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Goto -- TODO: Implement Eval instance for Goto
instance (MonadFail m) => Eval t v m Goto instance Member Fail es => Evaluatable es t v Goto
-- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell. -- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell.
@ -65,7 +66,7 @@ instance Ord1 Match where liftCompare = genericLiftCompare
instance Show1 Match where liftShowsPrec = genericLiftShowsPrec instance Show1 Match where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Match -- TODO: Implement Eval instance for Match
instance (MonadFail m) => Eval t v m Match instance Member Fail es => Evaluatable es t v Match
-- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions. -- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions.
@ -77,7 +78,7 @@ instance Ord1 Pattern where liftCompare = genericLiftCompare
instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Pattern -- TODO: Implement Eval instance for Pattern
instance (MonadFail m) => Eval t v m Pattern instance Member Fail es => Evaluatable es t v Pattern
-- | A let statement or local binding, like 'a as b' or 'let a = b'. -- | A let statement or local binding, like 'a as b' or 'let a = b'.
@ -89,7 +90,7 @@ instance Ord1 Let where liftCompare = genericLiftCompare
instance Show1 Let where liftShowsPrec = genericLiftShowsPrec instance Show1 Let where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Let -- TODO: Implement Eval instance for Let
instance (MonadFail m) => Eval t v m Let instance Member Fail es => Evaluatable es t v Let
-- Assignment -- Assignment
@ -102,21 +103,23 @@ instance Eq1 Assignment where liftEq = genericLiftEq
instance Ord1 Assignment where liftCompare = genericLiftCompare instance Ord1 Assignment where liftCompare = genericLiftCompare
instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
instance ( Monad m instance ( Semigroup (Cell (LocationFor v) v)
, Semigroup (Cell (LocationFor v) v) , MonadAddress (LocationFor v) es
, MonadAddress (LocationFor v) m
, MonadStore v m
, MonadEnv v m
, FreeVariables t , FreeVariables t
, Member (Reader (EnvironmentFor v)) es
, Member (State (EnvironmentFor v)) es
, Member (State (Store (LocationFor v) v)) es
, Evaluatable es t v (Base t)
, Recursive t
) )
=> Eval t v m Assignment where => Evaluatable es t v Assignment where
eval ev yield Assignment{..} = do eval Assignment{..} = do
env <- askEnv env <- ask
v <- ev pure assignmentValue v <- step assignmentValue
(var, a) <- envLookupOrAlloc' assignmentTarget env v (var, a) <- envLookupOrAlloc' assignmentTarget env v
localEnv (envInsert var a) (yield v) modify (envInsert var a)
pure v
-- | Post increment operator (e.g. 1++ in Go, or i++ in C). -- | Post increment operator (e.g. 1++ in Go, or i++ in C).
newtype PostIncrement a = PostIncrement a newtype PostIncrement a = PostIncrement a
@ -127,7 +130,7 @@ instance Ord1 PostIncrement where liftCompare = genericLiftCompare
instance Show1 PostIncrement where liftShowsPrec = genericLiftShowsPrec instance Show1 PostIncrement where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for PostIncrement -- TODO: Implement Eval instance for PostIncrement
instance (MonadFail m) => Eval t v m PostIncrement instance Member Fail es => Evaluatable es t v PostIncrement
-- | Post decrement operator (e.g. 1-- in Go, or i-- in C). -- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
@ -139,7 +142,7 @@ instance Ord1 PostDecrement where liftCompare = genericLiftCompare
instance Show1 PostDecrement where liftShowsPrec = genericLiftShowsPrec instance Show1 PostDecrement where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for PostDecrement -- TODO: Implement Eval instance for PostDecrement
instance (MonadFail m) => Eval t v m PostDecrement instance Member Fail es => Evaluatable es t v PostDecrement
-- Returns -- Returns
@ -151,15 +154,9 @@ instance Eq1 Return where liftEq = genericLiftEq
instance Ord1 Return where liftCompare = genericLiftCompare instance Ord1 Return where liftCompare = genericLiftCompare
instance Show1 Return where liftShowsPrec = genericLiftShowsPrec instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Return instance (Evaluatable es t v (Base t), Recursive t)
instance (MonadFail m) => Eval t v m Return where => Evaluatable es t v Return where
eval ev yield (Return a) = ev yield a eval (Return x) = step x
instance ( E3.Evaluatable es t v (E3.Base t)
, E3.Recursive t
)
=> E3.Evaluatable es t v Return where
eval (Return x) = E3.step x
newtype Yield a = Yield a newtype Yield a = Yield a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@ -169,7 +166,7 @@ instance Ord1 Yield where liftCompare = genericLiftCompare
instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Yield -- TODO: Implement Eval instance for Yield
instance (MonadFail m) => Eval t v m Yield instance Member Fail es => Evaluatable es t v Yield
newtype Break a = Break a newtype Break a = Break a
@ -180,7 +177,7 @@ instance Ord1 Break where liftCompare = genericLiftCompare
instance Show1 Break where liftShowsPrec = genericLiftShowsPrec instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Break -- TODO: Implement Eval instance for Break
instance (MonadFail m) => Eval t v m Break instance Member Fail es => Evaluatable es t v Break
newtype Continue a = Continue a newtype Continue a = Continue a
@ -191,7 +188,7 @@ instance Ord1 Continue where liftCompare = genericLiftCompare
instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Continue -- TODO: Implement Eval instance for Continue
instance (MonadFail m) => Eval t v m Continue instance Member Fail es => Evaluatable es t v Continue
newtype Retry a = Retry a newtype Retry a = Retry a
@ -202,7 +199,7 @@ instance Ord1 Retry where liftCompare = genericLiftCompare
instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Retry -- TODO: Implement Eval instance for Retry
instance (MonadFail m) => Eval t v m Retry instance Member Fail es => Evaluatable es t v Retry
newtype NoOp a = NoOp a newtype NoOp a = NoOp a
@ -213,7 +210,7 @@ instance Ord1 NoOp where liftCompare = genericLiftCompare
instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for NoOp -- TODO: Implement Eval instance for NoOp
instance (MonadFail m) => Eval t v m NoOp instance Member Fail es => Evaluatable es t v NoOp
-- Loops -- Loops
@ -226,7 +223,7 @@ instance Ord1 For where liftCompare = genericLiftCompare
instance Show1 For where liftShowsPrec = genericLiftShowsPrec instance Show1 For where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for For -- TODO: Implement Eval instance for For
instance (MonadFail m) => Eval t v m For instance Member Fail es => Evaluatable es t v For
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a } data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
@ -237,7 +234,7 @@ instance Ord1 ForEach where liftCompare = genericLiftCompare
instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for ForEach -- TODO: Implement Eval instance for ForEach
instance (MonadFail m) => Eval t v m ForEach instance Member Fail es => Evaluatable es t v ForEach
data While a = While { whileCondition :: !a, whileBody :: !a } data While a = While { whileCondition :: !a, whileBody :: !a }
@ -248,7 +245,7 @@ instance Ord1 While where liftCompare = genericLiftCompare
instance Show1 While where liftShowsPrec = genericLiftShowsPrec instance Show1 While where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for While -- TODO: Implement Eval instance for While
instance (MonadFail m) => Eval t v m While instance Member Fail es => Evaluatable es t v While
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a } data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
@ -259,7 +256,7 @@ instance Ord1 DoWhile where liftCompare = genericLiftCompare
instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for DoWhile -- TODO: Implement Eval instance for DoWhile
instance (MonadFail m) => Eval t v m DoWhile instance Member Fail es => Evaluatable es t v DoWhile
-- Exception handling -- Exception handling
@ -272,7 +269,7 @@ instance Ord1 Throw where liftCompare = genericLiftCompare
instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Throw -- TODO: Implement Eval instance for Throw
instance (MonadFail m) => Eval t v m Throw instance Member Fail es => Evaluatable es t v Throw
data Try a = Try { tryBody :: !a, tryCatch :: ![a] } data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
@ -283,7 +280,7 @@ instance Ord1 Try where liftCompare = genericLiftCompare
instance Show1 Try where liftShowsPrec = genericLiftShowsPrec instance Show1 Try where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Try -- TODO: Implement Eval instance for Try
instance (MonadFail m) => Eval t v m Try instance Member Fail es => Evaluatable es t v Try
data Catch a = Catch { catchException :: !a, catchBody :: !a } data Catch a = Catch { catchException :: !a, catchBody :: !a }
@ -294,7 +291,7 @@ instance Ord1 Catch where liftCompare = genericLiftCompare
instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Catch -- TODO: Implement Eval instance for Catch
instance (MonadFail m) => Eval t v m Catch instance Member Fail es => Evaluatable es t v Catch
newtype Finally a = Finally a newtype Finally a = Finally a
@ -305,7 +302,7 @@ instance Ord1 Finally where liftCompare = genericLiftCompare
instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Finally -- TODO: Implement Eval instance for Finally
instance (MonadFail m) => Eval t v m Finally instance Member Fail es => Evaluatable es t v Finally
-- Scoping -- Scoping
@ -319,7 +316,7 @@ instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
instance Show1 ScopeEntry where liftShowsPrec = genericLiftShowsPrec instance Show1 ScopeEntry where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for ScopeEntry -- TODO: Implement Eval instance for ScopeEntry
instance (MonadFail m) => Eval t v m ScopeEntry instance Member Fail es => Evaluatable es t v ScopeEntry
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl). -- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
@ -331,4 +328,4 @@ instance Ord1 ScopeExit where liftCompare = genericLiftCompare
instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for ScopeExit -- TODO: Implement Eval instance for ScopeExit
instance (MonadFail m) => Eval t v m ScopeExit instance Member Fail es => Evaluatable es t v ScopeExit

View File

@ -1,12 +1,13 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, UndecidableInstances #-} {-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, UndecidableInstances #-}
module Data.Syntax.Type where module Data.Syntax.Type where
import Data.Abstract.Eval import Control.Monad.Effect.Fail
import qualified Data.Abstract.Eval3 as E3 import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Align.Generic import Data.Align.Generic
import Data.Functor.Classes.Generic import Data.Functor.Classes.Generic
import Data.Mergeable import Data.Mergeable
import Data.Union
import Diffing.Algorithm import Diffing.Algorithm
import GHC.Generics import GHC.Generics
@ -18,7 +19,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Array -- TODO: Implement Eval instance for Array
instance (MonadFail m) => Eval t v m Array instance Member Fail es => Evaluatable es t v Array
-- TODO: What about type variables? re: FreeVariables1 -- TODO: What about type variables? re: FreeVariables1
@ -29,15 +30,10 @@ instance Eq1 Annotation where liftEq = genericLiftEq
instance Ord1 Annotation where liftCompare = genericLiftCompare instance Ord1 Annotation where liftCompare = genericLiftCompare
instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
-- TODO: Specialize Eval for Type to unify the inferred type of the subject with the specified type -- TODO: Specialize Evaluatable for Type to unify the inferred type of the subject with the specified type
instance (Monad m) => Eval t v m Annotation where instance (Evaluatable es t v (Base t), Recursive t)
eval recur yield Annotation{..} = recur yield annotationSubject => Evaluatable es t v Annotation where
eval Annotation{..} = step annotationSubject
instance ( E3.Evaluatable es t v (E3.Base t)
, E3.Recursive t
)
=> E3.Evaluatable es t v Annotation where
eval Annotation{..} = E3.step annotationSubject
data Function a = Function { functionParameters :: [a], functionReturn :: a } data Function a = Function { functionParameters :: [a], functionReturn :: a }
@ -48,7 +44,7 @@ instance Ord1 Function where liftCompare = genericLiftCompare
instance Show1 Function where liftShowsPrec = genericLiftShowsPrec instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Function -- TODO: Implement Eval instance for Function
instance (MonadFail m) => Eval t v m Function instance Member Fail es => Evaluatable es t v Function
newtype Interface a = Interface [a] newtype Interface a = Interface [a]
@ -59,7 +55,7 @@ instance Ord1 Interface where liftCompare = genericLiftCompare
instance Show1 Interface where liftShowsPrec = genericLiftShowsPrec instance Show1 Interface where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Interface -- TODO: Implement Eval instance for Interface
instance (MonadFail m) => Eval t v m Interface instance Member Fail es => Evaluatable es t v Interface
data Map a = Map { mapKeyType :: a, mapElementType :: a } data Map a = Map { mapKeyType :: a, mapElementType :: a }
@ -70,7 +66,7 @@ instance Ord1 Map where liftCompare = genericLiftCompare
instance Show1 Map where liftShowsPrec = genericLiftShowsPrec instance Show1 Map where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Map -- TODO: Implement Eval instance for Map
instance (MonadFail m) => Eval t v m Map instance Member Fail es => Evaluatable es t v Map
newtype Parenthesized a = Parenthesized a newtype Parenthesized a = Parenthesized a
@ -81,7 +77,7 @@ instance Ord1 Parenthesized where liftCompare = genericLiftCompare
instance Show1 Parenthesized where liftShowsPrec = genericLiftShowsPrec instance Show1 Parenthesized where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Parenthesized -- TODO: Implement Eval instance for Parenthesized
instance (MonadFail m) => Eval t v m Parenthesized instance Member Fail es => Evaluatable es t v Parenthesized
newtype Pointer a = Pointer a newtype Pointer a = Pointer a
@ -92,7 +88,7 @@ instance Ord1 Pointer where liftCompare = genericLiftCompare
instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Pointer -- TODO: Implement Eval instance for Pointer
instance (MonadFail m) => Eval t v m Pointer instance Member Fail es => Evaluatable es t v Pointer
newtype Product a = Product [a] newtype Product a = Product [a]
@ -103,7 +99,7 @@ instance Ord1 Product where liftCompare = genericLiftCompare
instance Show1 Product where liftShowsPrec = genericLiftShowsPrec instance Show1 Product where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Product -- TODO: Implement Eval instance for Product
instance (MonadFail m) => Eval t v m Product instance Member Fail es => Evaluatable es t v Product
data Readonly a = Readonly data Readonly a = Readonly
@ -114,7 +110,7 @@ instance Ord1 Readonly where liftCompare = genericLiftCompare
instance Show1 Readonly where liftShowsPrec = genericLiftShowsPrec instance Show1 Readonly where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Readonly -- TODO: Implement Eval instance for Readonly
instance (MonadFail m) => Eval t v m Readonly instance Member Fail es => Evaluatable es t v Readonly
newtype Slice a = Slice a newtype Slice a = Slice a
@ -125,7 +121,7 @@ instance Ord1 Slice where liftCompare = genericLiftCompare
instance Show1 Slice where liftShowsPrec = genericLiftShowsPrec instance Show1 Slice where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Slice -- TODO: Implement Eval instance for Slice
instance (MonadFail m) => Eval t v m Slice instance Member Fail es => Evaluatable es t v Slice
newtype TypeParameters a = TypeParameters [a] newtype TypeParameters a = TypeParameters [a]
@ -136,4 +132,4 @@ instance Ord1 TypeParameters where liftCompare = genericLiftCompare
instance Show1 TypeParameters where liftShowsPrec = genericLiftShowsPrec instance Show1 TypeParameters where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for TypeParameters -- TODO: Implement Eval instance for TypeParameters
instance (MonadFail m) => Eval t v m TypeParameters instance Member Fail es => Evaluatable es t v TypeParameters

View File

@ -1,12 +1,14 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-}
module Language.Python.Syntax where module Language.Python.Syntax where
import Diffing.Algorithm import Control.Monad.Effect.Fail
import Data.Abstract.Eval import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Align.Generic import Data.Align.Generic
import Data.Functor.Classes.Generic import Data.Functor.Classes.Generic
import Data.Mergeable import Data.Mergeable
import Data.Union
import Diffing.Algorithm
import GHC.Generics import GHC.Generics
-- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell) -- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
@ -18,7 +20,7 @@ instance Ord1 Ellipsis where liftCompare = genericLiftCompare
instance Show1 Ellipsis where liftShowsPrec = genericLiftShowsPrec instance Show1 Ellipsis where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Ellipsis -- TODO: Implement Eval instance for Ellipsis
instance (MonadFail m) => Eval t v m Ellipsis instance Member Fail es => Evaluatable es t v Ellipsis
data Redirect a = Redirect !a !a data Redirect a = Redirect !a !a
@ -29,4 +31,4 @@ instance Ord1 Redirect where liftCompare = genericLiftCompare
instance Show1 Redirect where liftShowsPrec = genericLiftShowsPrec instance Show1 Redirect where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Redirect -- TODO: Implement Eval instance for Redirect
instance (MonadFail m) => Eval t v m Redirect instance Member Fail es => Evaluatable es t v Redirect