diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 64664a984..a0b3d4a4c 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -15,13 +15,11 @@ library hs-source-dirs: src exposed-modules: -- Analyses & term annotations - Analysis.Abstract.Caching - , Analysis.Abstract.Collecting - , Analysis.Abstract.Dead - , Analysis.Abstract.Evaluating - , Analysis.Abstract.Evaluating2 - , Analysis.Abstract.Evaluating3 - , Analysis.Abstract.Tracing + -- Analysis.Abstract.Caching + -- , Analysis.Abstract.Collecting + -- , Analysis.Abstract.Dead + Analysis.Abstract.Evaluating + -- , Analysis.Abstract.Tracing , Analysis.ConstructorName , Analysis.CyclomaticComplexity , Analysis.Decorator @@ -49,9 +47,7 @@ library , Data.Abstract.Configuration , Data.Abstract.Environment , Data.Abstract.Linker - , Data.Abstract.Eval - , Data.Abstract.Eval2 - , Data.Abstract.Eval3 + , Data.Abstract.Evaluatable , Data.Abstract.FreeVariables , Data.Abstract.Live , Data.Abstract.Store diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index f605ac4dc..fc98cce05 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -2,19 +2,14 @@ module Analysis.Abstract.Evaluating where import Control.Effect -import Control.Monad.Effect hiding (run) -import Control.Monad.Effect.Address +import Control.Monad.Effect (Eff, Members) import Control.Monad.Effect.Fail -import Control.Monad.Effect.Reader import Control.Monad.Effect.State -import Data.Abstract.Address -import Data.Abstract.Environment +import Control.Monad.Effect.Reader import Data.Abstract.Linker -import Data.Abstract.FreeVariables -import Data.Abstract.Eval +import Data.Abstract.Evaluatable 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 @@ -22,58 +17,47 @@ import Data.Semigroup import Prelude hiding (fail) import Data.Blob import System.FilePath.Posix - -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) +import Control.Monad.Effect.Embedded -- | The effects necessary for concrete interpretation. type Evaluating v - = '[ Fail -- For 'MonadFail'. - , State (Store (LocationFor v) v) -- For 'MonadStore'. - , Reader (Environment (LocationFor v) v) -- For 'MonadEnv'. - , Reader (Live (LocationFor v) v) -- For 'MonadGC'. - , Reader (Linker (Evaluator v)) -- For 'MonadLinker' + = '[ 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 (Cell (LocationFor v) v) - , Semigroup (Cell (LocationFor v) v) - , Functor (Base term) - , Recursive term - , MonadAddress (LocationFor v) (Eff (Evaluating v)) - , Eval term v (Eff (Evaluating v)) (Base term) - ) +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 go pure - where go recur yield = eval recur yield . project +evaluate = run @(Evaluating v) . fix (const step) -evaluates :: forall v term - . ( Ord v - , Ord (Cell (LocationFor v) v) - , Semigroup (Cell (LocationFor v) v) - , Functor (Base term) - , Recursive term - , AbstractValue v - , MonadAddress (LocationFor v) (Eff (Evaluating v)) - , FreeVariables term - , Eval term v (Eff (Evaluating v)) (Base term) - ) +-- | 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 pure +evaluates pairs = run @(Evaluating v) . fix go where - go recur yield (b@Blob{..}, t) = local (const (Linker (Map.fromList (map (toPathActionPair recur pure) pairs)))) $ - eval (\ev term -> recur ev (b, term)) yield (project t) - toPathActionPair recur yield (b@Blob{..}, t) = (dropExtensions blobPath, Evaluator (go recur yield (b, t))) + go _ (Blob{..}, t) = local (const (Linker (Map.fromList (map toPathActionPair pairs)))) (step @v t) + toPathActionPair (Blob{..}, t) = (dropExtensions blobPath, Evaluator (step @v t)) diff --git a/src/Analysis/Abstract/Evaluating2.hs b/src/Analysis/Abstract/Evaluating2.hs deleted file mode 100644 index a69690c87..000000000 --- a/src/Analysis/Abstract/Evaluating2.hs +++ /dev/null @@ -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) diff --git a/src/Analysis/Abstract/Evaluating3.hs b/src/Analysis/Abstract/Evaluating3.hs deleted file mode 100644 index 936a69e38..000000000 --- a/src/Analysis/Abstract/Evaluating3.hs +++ /dev/null @@ -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)) diff --git a/src/Control/Monad/Effect/Address.hs b/src/Control/Monad/Effect/Address.hs index 1ce1bc6b3..fa8672a51 100644 --- a/src/Control/Monad/Effect/Address.hs +++ b/src/Control/Monad/Effect/Address.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} module Control.Monad.Effect.Address where import Control.Applicative import Control.Monad ((<=<)) -import Control.Monad.Effect.Store -import Control.Monad.Fail as Fail +import Control.Monad.Effect (Eff) +import Control.Monad.Effect.Fail +import Control.Monad.Effect.State import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.FreeVariables @@ -13,55 +14,73 @@ import Data.Abstract.Value import Data.Foldable (asum, toList) import Data.Pointed import Data.Semigroup +import Data.Union +import Prelude hiding (fail) -- | 'Monad's offering 'alloc'ation and 'deref'erencing of 'Address'es. -class (Ord l, Pointed (Cell l), Monad m) => MonadAddress l m where - deref :: (MonadStore a m, MonadFail m, l ~ LocationFor a) => Address l a -> m a +class (Ord l, Pointed (Cell l)) => MonadAddress l es where + 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. -- -- 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' :: - ( FreeVariables t - , Semigroup (Cell (LocationFor a) a) - , MonadStore a m - , MonadAddress (LocationFor a) m - ) - => t -> Environment (LocationFor a) a -> a -> m (Name, Address (LocationFor a) a) +envLookupOrAlloc' :: ( FreeVariables t + , Semigroup (Cell (LocationFor a) a) + , Member (State (StoreFor a)) es + , MonadAddress (LocationFor a) es + ) + => t + -> Environment (LocationFor a) a + -> a + -> Eff es (Name, Address (LocationFor a) a) envLookupOrAlloc' term = let [name] = toList (freeVariables term) in envLookupOrAlloc name -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. -envLookupOrAlloc :: - ( Semigroup (Cell (LocationFor a) a) - , MonadStore a m - , MonadAddress (LocationFor a) m - ) - => Name -> Environment (LocationFor a) a -> a -> m (Name, Address (LocationFor a) a) +envLookupOrAlloc :: ( Semigroup (Cell (LocationFor a) a) + , Member (State (StoreFor a)) es + , MonadAddress (LocationFor a) es + ) + => Name + -> Environment (LocationFor a) a + -> a + -> Eff es (Name, Address (LocationFor a) a) envLookupOrAlloc name env v = do a <- maybe (alloc name) pure (envLookup name env) assign a v 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. -instance Monad m => MonadAddress Precise m where - deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup +instance MonadAddress Precise es where + 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 allocPrecise = Address . Precise . storeSize -- | '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 - deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup +instance (Alternative (Eff es)) => MonadAddress Monovariant es where + deref = asum . maybe [] (map pure . toList) <=< flip fmap get . storeLookup 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" diff --git a/src/Data/Abstract/Eval.hs b/src/Data/Abstract/Eval.hs deleted file mode 100644 index 13668aba7..000000000 --- a/src/Data/Abstract/Eval.hs +++ /dev/null @@ -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 child’s 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 statement’s 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 statement’s 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 diff --git a/src/Data/Abstract/Eval2.hs b/src/Data/Abstract/Eval2.hs deleted file mode 100644 index ceb92a9dc..000000000 --- a/src/Data/Abstract/Eval2.hs +++ /dev/null @@ -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 statement’s 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 statement’s 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) diff --git a/src/Data/Abstract/Eval3.hs b/src/Data/Abstract/Evaluatable.hs similarity index 95% rename from src/Data/Abstract/Eval3.hs rename to src/Data/Abstract/Evaluatable.hs index 8dfd8a11c..cbeaded96 100644 --- a/src/Data/Abstract/Eval3.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE MultiParamTypeClasses, Rank2Types, GADTs, TypeOperators, DefaultSignatures, UndecidableInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses, Rank2Types, GADTs, TypeOperators, DefaultSignatures, UndecidableInstances, ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Data.Abstract.Eval3 +module Data.Abstract.Evaluatable ( Evaluatable(..) -, EnvironmentFor , step , Linker , MonadGC(..) @@ -28,7 +27,6 @@ import Prelude hiding (fail) import Data.Union (Apply) 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 = eval . project diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 93376694f..1b41c9e34 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -3,6 +3,7 @@ module Data.Abstract.Value where import Data.Abstract.Address import Data.Abstract.Environment +import Data.Abstract.Store import Data.Abstract.FreeVariables import Data.Abstract.Live import qualified Data.Abstract.Type as Type @@ -78,6 +79,11 @@ instance Eq1 String where liftEq = genericLiftEq instance Ord1 String where liftCompare = genericLiftCompare 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. type family LocationFor value :: * where diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 8afe5e48b..6aab6bad5 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -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 -import qualified Assigning.Assignment as Assignment import Control.Applicative import Control.Monad.Effect 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.Reader +import Control.Monad.Effect.State import Control.Monad.Error.Class hiding (Error) -import Data.Abstract.Address import Data.Abstract.Environment -import Data.Abstract.Eval -import qualified Data.Abstract.Eval2 as E2 -import qualified Data.Abstract.Eval3 as E3 +import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables -import Data.Abstract.Value (LocationFor, AbstractValue(..), Value) -import qualified Data.Abstract.Value as Value -import qualified Data.Abstract.Type as Type +import Data.Abstract.Value (LocationFor, EnvironmentFor, StoreFor, AbstractValue(..), Value) import Data.Align.Generic import Data.AST import Data.ByteString (ByteString) import Data.ByteString.Char8 (unpack) -import qualified Data.Error as Error import Data.Foldable (asum, toList) import Data.Function ((&), on) +import Data.Functor.Classes.Generic import Data.Ix import Data.List.NonEmpty (NonEmpty(..), nonEmpty) -import Data.Functor.Classes.Generic import Data.Mergeable +import Data.Pointed import Data.Range import Data.Record -import Data.Pointed import Data.Semigroup import Data.Span import Data.Term @@ -42,6 +33,10 @@ import Diffing.Algorithm hiding (Empty) import GHC.Generics import GHC.Stack 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 @@ -134,30 +129,11 @@ instance Eq1 Identifier where liftEq = genericLiftEq instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec -instance ( MonadAddress (LocationFor v) m - , MonadEnv v m - , MonadFail m - , MonadStore v m - ) => Eval t v m 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 +instance ( MonadAddress (LocationFor v) es + , Member Fail es + , Member (Reader (EnvironmentFor v)) es + , Member (State (StoreFor v)) es + ) => Evaluatable es t v Identifier where eval (Identifier name) = do env <- ask 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 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)) , Show (LocationFor (Value l t)) - , E2.Recursive t - , E3.Evaluatable es t (Value l t) (E3.Base t) + , Recursive t + , Evaluatable es t (Value l t) (Base t) , FreeVariables t - , Members '[ - Fail, - State (E3.EnvironmentFor (Value l t)), - Reader (E3.EnvironmentFor (Value l t)) ] es + , Member Fail es + , Member (State (EnvironmentFor (Value l t))) es + , Member (Reader (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 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' [x] = E3.step x >>= interface + eval' [x] = step x >>= interface eval' (x:xs) = do - _ <- E3.step @(Value l t) x - env <- get @(E3.EnvironmentFor (Value l t)) + _ <- step @(Value l t) x + env <- get @(EnvironmentFor (Value l t)) 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. newtype AccessibilityModifier a = AccessibilityModifier ByteString @@ -250,7 +180,7 @@ instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare instance Show1 AccessibilityModifier where liftShowsPrec = genericLiftShowsPrec -- 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. -- @@ -262,13 +192,7 @@ instance Eq1 Empty where liftEq _ _ _ = True instance Ord1 Empty where liftCompare _ _ _ = EQ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty" -instance (Monad m, AbstractValue v) => Eval t v m 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 +instance (AbstractValue v) => Evaluatable es t v Empty where eval _ = pure unit @@ -280,9 +204,7 @@ instance Eq1 Error where liftEq = genericLiftEq instance Ord1 Error where liftCompare = genericLiftCompare instance Show1 Error where liftShowsPrec = genericLiftShowsPrec -instance (MonadFail m) => Eval t v m Error -instance (MonadFail m) => E2.Eval t v m Error -instance Member Fail es => E3.Evaluatable es t v Error +instance Member Fail es => Evaluatable es t v Error errorSyntax :: Error.Error String -> [a] -> Error a 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 Show1 Context where liftShowsPrec = genericLiftShowsPrec -instance (Monad m) => Eval t v m Context where - eval ev yield Context{..} = ev yield contextSubject +instance (Evaluatable es t v (Base t), Recursive t) + => Evaluatable es t v Context where + eval Context{..} = step contextSubject diff --git a/src/Data/Syntax/Comment.hs b/src/Data/Syntax/Comment.hs index e81b8194b..a3b322888 100644 --- a/src/Data/Syntax/Comment.hs +++ b/src/Data/Syntax/Comment.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} module Data.Syntax.Comment where -import Data.Abstract.Eval +import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables import Data.Abstract.Value as Value import Data.Align.Generic @@ -19,8 +19,8 @@ instance Eq1 Comment where liftEq = genericLiftEq instance Ord1 Comment where liftCompare = genericLiftCompare instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec -instance (Monad m, AbstractValue v) => Eval t v m Comment where - eval _ yield _ = yield unit +instance (AbstractValue v) => Evaluatable es t v Comment where + eval _ = pure unit -- TODO: nested comment types -- TODO: documentation comment types diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 89a9c5969..550ceee87 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -1,38 +1,31 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, UndecidableInstances #-} module Data.Syntax.Declaration where +import Analysis.Abstract.Evaluating 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.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.Environment -import Analysis.Abstract.Evaluating -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.Evaluatable 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.Align.Generic import Data.Foldable (toList) import Data.Functor.Classes.Generic import Data.Mergeable -import Data.Traversable import Data.Semigroup +import Data.Traversable import Data.Union import Diffing.Algorithm import GHC.Generics 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 } 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 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: Filter the closed-over environment by the free variables in the term. -instance ( Monad m - , 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) +-- TODO: How should we represent function types, where applicable? instance ( FreeVariables t , Semigroup (Cell l (Value l t)) - , MonadStore (Value l t) (Eff es) - , MonadAddress l (Eff es) - , Member (State (E3.EnvironmentFor (Value l t))) es - , Member (Reader (E3.EnvironmentFor (Value l t))) es - ) => E3.Evaluatable es t (Value l t) Function where + , MonadAddress l es + , Member (State (EnvironmentFor (Value l t))) es + , Member (Reader (EnvironmentFor (Value l t))) es + , Member (State (StoreFor (Value l t))) es + ) => Evaluatable es t (Value l t) Function where eval Function{..} = do - env <- ask @(E3.EnvironmentFor (Value l t)) + env <- ask @(EnvironmentFor (Value l t)) let params = toList (freeVariables1 functionParameters) let v = inj (Closure params functionBody env) :: Value l t @@ -105,9 +57,33 @@ instance ( FreeVariables t modify (envInsert name addr) 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 } 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 Show1 Method where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Method -instance (MonadFail m) => Eval t v m Method - --- Evaluating a Function creates a closure and makes that value available in the +-- Evaluating a Method creates a closure and makes that value available in the -- 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 , Semigroup (Cell l (Value l t)) -- envLookupOrAlloc' - , MonadStore (Value l t) (Eff es) -- envLookupOrAlloc' - , MonadAddress l (Eff es) -- envLookupOrAlloc' - , Member (State (E3.EnvironmentFor (Value l t))) es - , Member (Reader (E3.EnvironmentFor (Value l t))) es - ) => E3.Evaluatable es t (Value l t) Method where + , MonadAddress l es -- envLookupOrAlloc' + , Member (State (EnvironmentFor (Value l t))) es + , Member (Reader (EnvironmentFor (Value l t))) es + , Member (State (StoreFor (Value l t))) es + ) => Evaluatable es t (Value l t) Method where eval Method{..} = do - env <- ask @(E3.EnvironmentFor (Value l t)) + env <- ask @(EnvironmentFor (Value l t)) let params = toList (freeVariables1 methodParameters) 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) 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. 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 -- 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) instance Eq1 RequiredParameter where liftEq = genericLiftEq @@ -180,10 +136,10 @@ instance Ord1 RequiredParameter where liftCompare = genericLiftCompare instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec -- 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) instance Eq1 OptionalParameter where liftEq = genericLiftEq @@ -191,7 +147,7 @@ instance Ord1 OptionalParameter where liftCompare = genericLiftCompare instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec -- 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? @@ -206,7 +162,7 @@ instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -218,7 +174,7 @@ instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -230,7 +186,7 @@ instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec -- 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 } @@ -241,7 +197,7 @@ instance Ord1 Variable where liftCompare = genericLiftCompare instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec -- 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 } 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 -- 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] } @@ -265,7 +221,7 @@ instance Ord1 Module where liftCompare = genericLiftCompare instance Show1 Module where liftShowsPrec = genericLiftShowsPrec -- 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 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 -- 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. @@ -290,7 +246,7 @@ instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCo instance Show1 Data.Syntax.Declaration.Datatype where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -302,7 +258,7 @@ instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLif instance Show1 Data.Syntax.Declaration.Constructor where liftShowsPrec = genericLiftShowsPrec -- 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) @@ -314,7 +270,7 @@ instance Ord1 Comprehension where liftCompare = genericLiftCompare instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec -- 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. 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 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 , Show t - , Members (E3.Evaluating (Value l t)) es + , Members (Evaluating (Value l t)) es , FreeVariables t ) - => E3.Evaluatable es t (Value l t) Import where + => Evaluatable es t (Value l t) Import where eval (Import from _ _) = do 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. Interface _ env <- maybe (fail ("expected an interface, but got: " <> show interface)) @@ -368,7 +299,7 @@ instance ( Show l modify (envUnion env) 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 @@ -380,7 +311,7 @@ instance Ord1 ImportSymbol where liftCompare = genericLiftCompare instance Show1 ImportSymbol where liftShowsPrec = genericLiftShowsPrec -- 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). @@ -392,7 +323,7 @@ instance Ord1 Type where liftCompare = genericLiftCompare instance Show1 Type where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -404,4 +335,4 @@ instance Ord1 TypeAlias where liftCompare = genericLiftCompare instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for TypeAlias -instance (MonadFail m) => Eval t v m TypeAlias +instance Member Fail es => Evaluatable es t v TypeAlias diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 3863f0b82..434062723 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -1,32 +1,24 @@ -{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, TypeApplications #-} module Data.Syntax.Expression where -import Data.Proxy import Control.Monad.Effect -import Control.Monad.Effect.State -import Control.Monad.Effect.Reader 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.Reader +import Control.Monad.Effect.State import Data.Abstract.Address import Data.Abstract.Environment -import Data.Abstract.Eval -import qualified Data.Abstract.Eval2 as E2 -import qualified Data.Abstract.Eval3 as E3 +import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables import Data.Abstract.Type as Type -import Data.Abstract.Value (Value, Closure(..)) -import Data.Maybe -import Data.Union -import Data.Semigroup -import Data.Traversable +import Data.Abstract.Value (Value, Closure(..), LocationFor, EnvironmentFor, StoreFor) import Data.Align.Generic import Data.Functor.Classes.Generic +import Data.Maybe import Data.Mergeable +import Data.Semigroup +import Data.Traversable +import Data.Union import Diffing.Algorithm import GHC.Generics import Prelude hiding (fail) @@ -39,82 +31,44 @@ instance Eq1 Call where liftEq = genericLiftEq instance Ord1 Call where liftCompare = genericLiftCompare instance Show1 Call where liftShowsPrec = genericLiftShowsPrec + instance ( Ord l - , MonadFail m - , Semigroup (Cell l (Value l t)) - , MonadEnv (Value l t) m - , MonadStore (Value l t) m - , MonadAddress l m - ) - => Eval t (Value l t) m Call where - eval recur yield Call{..} = do - closure <- recur pure callFunction + , Semigroup (Cell l (Value l t)) -- 'assign' + , MonadAddress l es -- 'alloc' + , Member Fail es + , Member (State (EnvironmentFor (Value l t))) es + , Member (Reader (EnvironmentFor (Value l t))) es + , Member (State (StoreFor (Value l t))) es + , Evaluatable es t (Value l t) (Base t) + , Recursive t + ) => 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)) bindings <- for (zip names callParams) $ \(name, param) -> do - v <- recur pure param + v <- step param a <- alloc name assign a v 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 -instance ( MonadFail m - , MonadFresh m - , MonadGC Type m - , MonadEnv Type m - , FreeVariables t - ) - => Eval t Type m Call where - eval recur yield Call{..} = do - opTy <- recur pure callFunction - tvar <- fresh - inTys <- traverse (recur pure) callParams - _ :-> outTy <- opTy `unify` (Type.Product inTys :-> Var tvar) - 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) +-- instance ( MonadFail m +-- , MonadFresh m +-- , MonadGC Type m +-- , MonadEnv Type m +-- , FreeVariables t +-- ) +-- => Eval t Type m Call where +-- eval recur yield Call{..} = do +-- opTy <- recur pure callFunction +-- tvar <- fresh +-- inTys <- traverse (recur pure) callParams +-- _ :-> outTy <- opTy `unify` (Type.Product inTys :-> Var tvar) +-- yield outTy data Comparison a = LessThan !a !a @@ -130,7 +84,7 @@ instance Ord1 Comparison where liftCompare = genericLiftCompare instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -149,7 +103,7 @@ instance Ord1 Arithmetic where liftCompare = genericLiftCompare instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -165,7 +119,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -177,7 +131,7 @@ instance Ord1 Delete where liftCompare = genericLiftCompare instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -189,7 +143,7 @@ instance Ord1 SequenceExpression where liftCompare = genericLiftCompare instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -201,7 +155,7 @@ instance Ord1 Void where liftCompare = genericLiftCompare instance Show1 Void where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -213,7 +167,7 @@ instance Ord1 Typeof where liftCompare = genericLiftCompare instance Show1 Typeof where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -232,7 +186,7 @@ instance Ord1 Bitwise where liftCompare = genericLiftCompare instance Show1 Bitwise where liftShowsPrec = genericLiftShowsPrec -- 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) @@ -245,7 +199,7 @@ instance Ord1 MemberAccess where liftCompare = genericLiftCompare instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec -- 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]) @@ -259,7 +213,7 @@ instance Ord1 Subscript where liftCompare = genericLiftCompare instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec -- 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)) @@ -271,7 +225,7 @@ instance Ord1 Enumeration where liftCompare = genericLiftCompare instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -283,7 +237,7 @@ instance Ord1 InstanceOf where liftCompare = genericLiftCompare instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec -- 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++) @@ -295,7 +249,7 @@ instance Ord1 ScopeResolution where liftCompare = genericLiftCompare instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -307,7 +261,7 @@ instance Ord1 NonNullExpression where liftCompare = genericLiftCompare instance Show1 NonNullExpression where liftShowsPrec = genericLiftShowsPrec -- 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#. @@ -319,7 +273,7 @@ instance Ord1 Await where liftCompare = genericLiftCompare instance Show1 Await where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -331,7 +285,7 @@ instance Ord1 New where liftCompare = genericLiftCompare instance Show1 New where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -343,4 +297,4 @@ instance Ord1 Cast where liftCompare = genericLiftCompare instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Cast -instance (MonadFail m) => Eval t v m Cast +instance Member Fail es => Evaluatable es t v Cast diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 94831a7bc..9a27497b6 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -1,17 +1,17 @@ {-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses #-} module Data.Syntax.Literal where -import Data.Abstract.Eval -import qualified Data.Abstract.Eval2 as E2 -import qualified Data.Abstract.Eval3 as E3 +import Control.Monad.Effect.Fail +import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables import Data.Abstract.Value (AbstractValue(..)) import Data.Align.Generic -import Data.Maybe import Data.ByteString (ByteString) import Data.ByteString.Char8 (readInteger) import Data.Functor.Classes.Generic +import Data.Maybe import Data.Mergeable +import Data.Union import Diffing.Algorithm import GHC.Generics import Prelude @@ -31,8 +31,8 @@ instance Eq1 Boolean where liftEq = genericLiftEq instance Ord1 Boolean where liftCompare = genericLiftCompare instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec -instance (Monad m, AbstractValue v) => Eval t v m Boolean where - eval _ yield (Boolean x) = yield (boolean x) +instance AbstractValue v => Evaluatable es t v Boolean where + eval (Boolean x) = pure (boolean x) -- Numeric @@ -45,17 +45,7 @@ instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec -instance (Monad m, AbstractValue v) => Eval t v m 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 +instance AbstractValue v => Evaluatable es t v Data.Syntax.Literal.Integer where -- TODO: This instance probably shouldn't have readInteger? 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 -- 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` @@ -85,7 +75,7 @@ instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompar instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec -- 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` @@ -97,7 +87,7 @@ instance Ord1 Data.Syntax.Literal.Complex where liftCompare = genericLiftCompare instance Show1 Data.Syntax.Literal.Complex where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -111,7 +101,7 @@ instance Show1 Data.Syntax.Literal.String where liftShowsPrec = genericLiftShows -- TODO: Should string literal bodies include escapes too? -- 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. @@ -123,7 +113,7 @@ instance Ord1 InterpolationElement where liftCompare = genericLiftCompare instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -134,8 +124,8 @@ instance Eq1 TextElement where liftEq = genericLiftEq instance Ord1 TextElement where liftCompare = genericLiftCompare instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec -instance (Monad m, AbstractValue v) => Eval t v m TextElement where - eval _ yield (TextElement x) = yield (string x) +instance AbstractValue v => Evaluatable es t v TextElement where + eval (TextElement x) = pure (string x) data Null a = Null 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 -- 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 } @@ -156,7 +146,7 @@ instance Ord1 Symbol where liftCompare = genericLiftCompare instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec -- 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 } @@ -170,7 +160,7 @@ instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec -- TODO: Character literals. -- TODO: Implement Eval instance for Regex -instance (MonadFail m) => Eval t v m Regex +instance Member Fail es => Evaluatable es t v Regex -- Collections @@ -183,7 +173,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare instance Show1 Array where liftShowsPrec = genericLiftShowsPrec -- 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] } @@ -194,7 +184,7 @@ instance Ord1 Hash where liftCompare = genericLiftCompare instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec -- 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 } @@ -205,7 +195,7 @@ instance Ord1 KeyValue where liftCompare = genericLiftCompare instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec -- 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] } @@ -216,7 +206,7 @@ instance Ord1 Tuple where liftCompare = genericLiftCompare instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec -- 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] } @@ -227,7 +217,7 @@ instance Ord1 Set where liftCompare = genericLiftCompare instance Show1 Set where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Set -instance (MonadFail m) => Eval t v m Set +instance Member Fail es => Evaluatable es t v Set -- Pointers @@ -241,7 +231,7 @@ instance Ord1 Pointer where liftCompare = genericLiftCompare instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec -- 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) @@ -253,7 +243,7 @@ instance Ord1 Reference where liftCompare = genericLiftCompare instance Show1 Reference where liftShowsPrec = genericLiftShowsPrec -- 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: Function literals (lambdas, procs, anonymous functions, what have you). diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index dca99beb5..876d36889 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -1,23 +1,24 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} module Data.Syntax.Statement where +import Control.Monad.Effect (Eff) import Control.Monad.Effect.Address -import Control.Monad.Effect.Env -import Control.Monad.Effect.Store 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.Eval -import qualified Data.Abstract.Eval3 as E3 +import Data.Abstract.Store +import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables import Data.Abstract.Value -import Data.Semigroup import Data.Align.Generic import Data.Functor.Classes.Generic import Data.Mergeable +import Data.Semigroup +import Data.Union import Diffing.Algorithm 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. 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 -- 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. @@ -40,7 +41,7 @@ instance Ord1 Else where liftCompare = genericLiftCompare instance Show1 Else where liftShowsPrec = genericLiftShowsPrec -- 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) @@ -53,7 +54,7 @@ instance Ord1 Goto where liftCompare = genericLiftCompare instance Show1 Goto where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -65,7 +66,7 @@ instance Ord1 Match where liftCompare = genericLiftCompare instance Show1 Match where liftShowsPrec = genericLiftShowsPrec -- 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. @@ -77,7 +78,7 @@ instance Ord1 Pattern where liftCompare = genericLiftCompare instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec -- 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'. @@ -89,7 +90,7 @@ instance Ord1 Let where liftCompare = genericLiftCompare instance Show1 Let where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Let -instance (MonadFail m) => Eval t v m Let +instance Member Fail es => Evaluatable es t v Let -- Assignment @@ -102,21 +103,23 @@ instance Eq1 Assignment where liftEq = genericLiftEq instance Ord1 Assignment where liftCompare = genericLiftCompare instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec -instance ( Monad m - , Semigroup (Cell (LocationFor v) v) - , MonadAddress (LocationFor v) m - , MonadStore v m - , MonadEnv v m +instance ( Semigroup (Cell (LocationFor v) v) + , MonadAddress (LocationFor v) es , 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 - eval ev yield Assignment{..} = do - env <- askEnv - v <- ev pure assignmentValue - + => Evaluatable es t v Assignment where + eval Assignment{..} = do + env <- ask + v <- step assignmentValue (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). newtype PostIncrement a = PostIncrement a @@ -127,7 +130,7 @@ instance Ord1 PostIncrement where liftCompare = genericLiftCompare instance Show1 PostIncrement where liftShowsPrec = genericLiftShowsPrec -- 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). @@ -139,7 +142,7 @@ instance Ord1 PostDecrement where liftCompare = genericLiftCompare instance Show1 PostDecrement where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for PostDecrement -instance (MonadFail m) => Eval t v m PostDecrement +instance Member Fail es => Evaluatable es t v PostDecrement -- Returns @@ -151,15 +154,9 @@ instance Eq1 Return where liftEq = genericLiftEq instance Ord1 Return where liftCompare = genericLiftCompare instance Show1 Return where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Return -instance (MonadFail m) => Eval t v m Return where - eval ev yield (Return a) = ev yield a - -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 +instance (Evaluatable es t v (Base t), Recursive t) + => Evaluatable es t v Return where + eval (Return x) = step x newtype Yield a = Yield a 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 -- 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 @@ -180,7 +177,7 @@ instance Ord1 Break where liftCompare = genericLiftCompare instance Show1 Break where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -191,7 +188,7 @@ instance Ord1 Continue where liftCompare = genericLiftCompare instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -202,7 +199,7 @@ instance Ord1 Retry where liftCompare = genericLiftCompare instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -213,7 +210,7 @@ instance Ord1 NoOp where liftCompare = genericLiftCompare instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for NoOp -instance (MonadFail m) => Eval t v m NoOp +instance Member Fail es => Evaluatable es t v NoOp -- Loops @@ -226,7 +223,7 @@ instance Ord1 For where liftCompare = genericLiftCompare instance Show1 For where liftShowsPrec = genericLiftShowsPrec -- 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 } @@ -237,7 +234,7 @@ instance Ord1 ForEach where liftCompare = genericLiftCompare instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec -- 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 } @@ -248,7 +245,7 @@ instance Ord1 While where liftCompare = genericLiftCompare instance Show1 While where liftShowsPrec = genericLiftShowsPrec -- 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 } @@ -259,7 +256,7 @@ instance Ord1 DoWhile where liftCompare = genericLiftCompare instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -272,7 +269,7 @@ instance Ord1 Throw where liftCompare = genericLiftCompare instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec -- 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] } @@ -283,7 +280,7 @@ instance Ord1 Try where liftCompare = genericLiftCompare instance Show1 Try where liftShowsPrec = genericLiftShowsPrec -- 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 } @@ -294,7 +291,7 @@ instance Ord1 Catch where liftCompare = genericLiftCompare instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -305,7 +302,7 @@ instance Ord1 Finally where liftCompare = genericLiftCompare instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Finally -instance (MonadFail m) => Eval t v m Finally +instance Member Fail es => Evaluatable es t v Finally -- Scoping @@ -319,7 +316,7 @@ instance Ord1 ScopeEntry where liftCompare = genericLiftCompare instance Show1 ScopeEntry where liftShowsPrec = genericLiftShowsPrec -- 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). @@ -331,4 +328,4 @@ instance Ord1 ScopeExit where liftCompare = genericLiftCompare instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for ScopeExit -instance (MonadFail m) => Eval t v m ScopeExit +instance Member Fail es => Evaluatable es t v ScopeExit diff --git a/src/Data/Syntax/Type.hs b/src/Data/Syntax/Type.hs index 6b9eed014..af9829795 100644 --- a/src/Data/Syntax/Type.hs +++ b/src/Data/Syntax/Type.hs @@ -1,12 +1,13 @@ {-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, UndecidableInstances #-} module Data.Syntax.Type where -import Data.Abstract.Eval -import qualified Data.Abstract.Eval3 as E3 +import Control.Monad.Effect.Fail +import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables import Data.Align.Generic import Data.Functor.Classes.Generic import Data.Mergeable +import Data.Union import Diffing.Algorithm import GHC.Generics @@ -18,7 +19,7 @@ instance Ord1 Array where liftCompare = genericLiftCompare instance Show1 Array where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -29,15 +30,10 @@ instance Eq1 Annotation where liftEq = genericLiftEq instance Ord1 Annotation where liftCompare = genericLiftCompare instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec --- TODO: Specialize Eval for Type to unify the inferred type of the subject with the specified type -instance (Monad m) => Eval t v m Annotation where - eval recur yield Annotation{..} = recur yield 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 +-- TODO: Specialize Evaluatable for Type to unify the inferred type of the subject with the specified type +instance (Evaluatable es t v (Base t), Recursive t) + => Evaluatable es t v Annotation where + eval Annotation{..} = step annotationSubject data Function a = Function { functionParameters :: [a], functionReturn :: a } @@ -48,7 +44,7 @@ instance Ord1 Function where liftCompare = genericLiftCompare instance Show1 Function where liftShowsPrec = genericLiftShowsPrec -- 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] @@ -59,7 +55,7 @@ instance Ord1 Interface where liftCompare = genericLiftCompare instance Show1 Interface where liftShowsPrec = genericLiftShowsPrec -- 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 } @@ -70,7 +66,7 @@ instance Ord1 Map where liftCompare = genericLiftCompare instance Show1 Map where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -81,7 +77,7 @@ instance Ord1 Parenthesized where liftCompare = genericLiftCompare instance Show1 Parenthesized where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -92,7 +88,7 @@ instance Ord1 Pointer where liftCompare = genericLiftCompare instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec -- 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] @@ -103,7 +99,7 @@ instance Ord1 Product where liftCompare = genericLiftCompare instance Show1 Product where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -114,7 +110,7 @@ instance Ord1 Readonly where liftCompare = genericLiftCompare instance Show1 Readonly where liftShowsPrec = genericLiftShowsPrec -- 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 @@ -125,7 +121,7 @@ instance Ord1 Slice where liftCompare = genericLiftCompare instance Show1 Slice where liftShowsPrec = genericLiftShowsPrec -- 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] @@ -136,4 +132,4 @@ instance Ord1 TypeParameters where liftCompare = genericLiftCompare instance Show1 TypeParameters where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for TypeParameters -instance (MonadFail m) => Eval t v m TypeParameters +instance Member Fail es => Evaluatable es t v TypeParameters diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 417a0f3fd..a61e039b9 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -1,12 +1,14 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} module Language.Python.Syntax where -import Diffing.Algorithm -import Data.Abstract.Eval +import Control.Monad.Effect.Fail +import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables import Data.Align.Generic import Data.Functor.Classes.Generic import Data.Mergeable +import Data.Union +import Diffing.Algorithm import GHC.Generics -- | 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 -- 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 @@ -29,4 +31,4 @@ instance Ord1 Redirect where liftCompare = genericLiftCompare instance Show1 Redirect where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for Redirect -instance (MonadFail m) => Eval t v m Redirect +instance Member Fail es => Evaluatable es t v Redirect