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

Pair down to a single, new Evaluatable

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
semantic-diff.cabal
View File

@ -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

78
src/Analysis/Abstract/Evaluating.hs
View File

@ -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))

43
src/Analysis/Abstract/Evaluating2.hs
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)

63
src/Analysis/Abstract/Evaluating3.hs
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))

77
src/Control/Monad/Effect/Address.hs
View File

@ -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"

59
src/Data/Abstract/Eval.hs
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 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

95
src/Data/Abstract/Eval2.hs
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 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)

6
src/Data/Abstract/Eval3.hs → src/Data/Abstract/Evaluatable.hs
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 #-}
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

6
src/Data/Abstract/Value.hs
View File

@ -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

143
src/Data/Syntax.hs
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
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

6
src/Data/Syntax/Comment.hs
View File

@ -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

215
src/Data/Syntax/Declaration.hs
View File

@ -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

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

@ -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

58
src/Data/Syntax/Literal.hs
View File

@ -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).

95
src/Data/Syntax/Statement.hs
View File

@ -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

38
src/Data/Syntax/Type.hs
View File

@ -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

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

@ -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