From 8eca025beb019624a2dab7cbbb0abfc74bae3722 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:01:50 -0400 Subject: [PATCH 01/88] Stub in an Env effect. --- src/Control/Abstract/Environment.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a2306cabf..58502ded1 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -11,6 +11,7 @@ module Control.Abstract.Environment , localEnv , localize , lookupEnv +, Env(..) , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -70,6 +71,10 @@ lookupEnv :: (Member (Reader (Environment location)) effects, Member (State (Env lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) +data Env location return where + Lookup :: Name -> Env location (Maybe location) + + -- | Errors involving the environment. data EnvironmentError location return where FreeVariable :: Name -> EnvironmentError location location From 0d226bb72d7c7fb9fa395523f59811b8b77f2fe1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:02:42 -0400 Subject: [PATCH 02/88] Add a handler for Env. --- src/Control/Abstract/Environment.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 58502ded1..0c809dd9c 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -12,6 +12,7 @@ module Control.Abstract.Environment , localize , lookupEnv , Env(..) +, runEnv , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -75,6 +76,10 @@ data Env location return where Lookup :: Name -> Env location (Maybe location) +runEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value (Env location ': effects) a -> Evaluator location value effects a +runEnv = interpret (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) + + -- | Errors involving the environment. data EnvironmentError location return where FreeVariable :: Name -> EnvironmentError location location From 6535eebf0a32a2a5a2ddd577b68ee416e69ec4a1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:02:55 -0400 Subject: [PATCH 03/88] Add a reinterpreting handler for Env. --- src/Control/Abstract/Environment.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 0c809dd9c..bb407605a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -13,6 +13,7 @@ module Control.Abstract.Environment , lookupEnv , Env(..) , runEnv +, reinterpretEnv , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -79,6 +80,9 @@ data Env location return where runEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value (Env location ': effects) a -> Evaluator location value effects a runEnv = interpret (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) +reinterpretEnv :: Evaluator location value (Env location ': effects) a -> Evaluator location value (Reader (Environment location) ': State (Environment location) ': effects) a +reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) + -- | Errors involving the environment. data EnvironmentError location return where From afc99742c619e2cbc06ce1e39e66d371a79c0fbe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:03:22 -0400 Subject: [PATCH 04/88] lookupEnv is an Env request. --- src/Control/Abstract/Environment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index bb407605a..71a9f4521 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -69,8 +69,8 @@ localize :: Member (State (Environment location)) effects => Evaluator location localize = localEnv id -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. -lookupEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Name -> Evaluator location value effects (Maybe (Address location value)) -lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) +lookupEnv :: Member (Env location) effects => Name -> Evaluator location value effects (Maybe (Address location value)) +lookupEnv name = fmap Address <$> send (Lookup name) data Env location return where From 576dba9b0c4ed1ed869e2192747544b8340bd8d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:04:24 -0400 Subject: [PATCH 05/88] Use Env effects in Heap. --- src/Control/Abstract/Heap.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 05eec53e0..def51bb2a 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -64,8 +64,7 @@ assign address = modifyHeap . heapInsert address -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( Member (Allocator location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects + , Member (Env location) effects ) => Name -> Evaluator location value effects (Address location value) @@ -73,8 +72,7 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( Member (Allocator location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects + , Member (Env location) effects , Member (State (Heap location (Cell location) value)) effects , Ord location , Reducer value (Cell location value) @@ -90,8 +88,7 @@ letrec name body = do -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. letrec' :: ( Member (Allocator location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects + , Member (Env location) effects ) => Name -> (Address location value -> Evaluator location value effects value) @@ -104,9 +101,8 @@ letrec' name body = do -- | Look up and dereference the given 'Name', throwing an exception for free variables. variable :: ( Member (Allocator location value) effects - , Member (Reader (Environment location)) effects + , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects ) => Name -> Evaluator location value effects value From 9b88dcbaf717f11807226714c827d376a4be53e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:16:17 -0400 Subject: [PATCH 06/88] =?UTF-8?q?Don=E2=80=99t=20use=20Address=20in=20the?= =?UTF-8?q?=20data,=20only=20in=20the=20effects.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Environment.hs | 4 ++-- src/Control/Abstract/Exports.hs | 2 +- src/Data/Abstract/Environment.hs | 17 ++++++++--------- src/Data/Abstract/Exports.hs | 7 +++---- src/Data/Abstract/Heap.hs | 2 +- src/Data/Abstract/Live.hs | 23 +++++++++++------------ 6 files changed, 26 insertions(+), 29 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 71a9f4521..f207e57ae 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -78,10 +78,10 @@ data Env location return where runEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value (Env location ': effects) a -> Evaluator location value effects a -runEnv = interpret (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) +runEnv = interpret (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) reinterpretEnv :: Evaluator location value (Env location ': effects) a -> Evaluator location value (Reader (Environment location) ': State (Environment location) ': effects) a -reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (fmap unAddress . Env.lookup name <$> getEnv) <*> (fmap unAddress . Env.lookup name <$> defaultEnvironment)) +reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) -- | Errors involving the environment. diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index e31e8d376..b9c8a307d 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -26,7 +26,7 @@ modifyExports = modify' -- | Add an export to the global export state. addExport :: Member (State (Exports location)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location value effects () -addExport name alias = modifyExports . insert name alias +addExport name alias = modifyExports . insert name alias . fmap unAddress -- | Sets the global export state for the lifetime of the given action. withExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects a -> Evaluator location value effects a diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 924df9d4a..19a9d8858 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -18,7 +18,6 @@ module Data.Abstract.Environment , roots ) where -import Data.Abstract.Address import Data.Abstract.Live import Data.Abstract.Name import Data.Align @@ -72,22 +71,22 @@ mergeNewer (Environment a) (Environment b) = -- -- >>> pairs shadowed -- [("foo",Precise 1)] -pairs :: Environment location -> [(Name, Address location value)] -pairs = map (second Address) . Map.toList . fold . unEnvironment +pairs :: Environment location -> [(Name, location)] +pairs = Map.toList . fold . unEnvironment -unpairs :: [(Name, Address location value)] -> Environment location -unpairs = Environment . pure . Map.fromList . map (second unAddress) +unpairs :: [(Name, location)] -> Environment location +unpairs = Environment . pure . Map.fromList -- | Lookup a 'Name' in the environment. -- -- >>> lookup (name "foo") shadowed -- Just (Precise 1) -lookup :: Name -> Environment location -> Maybe (Address location value) -lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment +lookup :: Name -> Environment location -> Maybe location +lookup k = foldMapA (Map.lookup k) . unEnvironment -- | Insert a 'Name' in the environment. -insert :: Name -> Address location value -> Environment location -> Environment location -insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as) +insert :: Name -> location -> Environment location -> Environment location +insert name address (Environment (a :| as)) = Environment (Map.insert name address a :| as) -- | Remove a 'Name' from the environment. -- diff --git a/src/Data/Abstract/Exports.hs b/src/Data/Abstract/Exports.hs index 4c71e508d..bc31a099d 100644 --- a/src/Data/Abstract/Exports.hs +++ b/src/Data/Abstract/Exports.hs @@ -9,7 +9,6 @@ module Data.Abstract.Exports import Prelude hiding (null) import Prologue hiding (null) -import Data.Abstract.Address import Data.Abstract.Environment (Environment, unpairs) import Data.Abstract.Name import qualified Data.Map as Map @@ -23,10 +22,10 @@ null :: Exports location -> Bool null = Map.null . unExports toEnvironment :: Exports location -> Environment location -toEnvironment exports = unpairs (mapMaybe (traverse (fmap Address)) (toList (unExports exports))) +toEnvironment exports = unpairs (mapMaybe sequenceA (toList (unExports exports))) -insert :: Name -> Name -> Maybe (Address location value) -> Exports location -> Exports location -insert name alias address = Exports . Map.insert name (alias, unAddress <$> address) . unExports +insert :: Name -> Name -> Maybe location -> Exports location -> Exports location +insert name alias address = Exports . Map.insert name (alias, address) . unExports -- TODO: Should we filter for duplicates here? aliases :: Exports location -> [(Name, Name)] diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index a383a5e42..0a878d03b 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -34,7 +34,7 @@ heapSize = Monoidal.size . unHeap -- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest). heapRestrict :: Ord location => Heap location cell value -> Live location value -> Heap location cell value -heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m) +heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) instance (Ord location, Reducer value (cell value)) => Reducer (Address location value, value) (Heap location cell value) where diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index 930350395..345d9f873 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-} module Data.Abstract.Live where -import Data.Abstract.Address import Data.Semilattice.Lower import Data.Set as Set import Prologue @@ -10,32 +9,32 @@ import Prologue newtype Live location value = Live { unLive :: Set location } deriving (Eq, Lower, Monoid, Ord, Semigroup) -fromAddresses :: (Foldable t, Ord location) => t (Address location value) -> Live location value +fromAddresses :: (Foldable t, Ord location) => t location -> Live location value fromAddresses = Prologue.foldr liveInsert lowerBound -- | Construct a 'Live' set containing only the given address. -liveSingleton :: Address location value -> Live location value -liveSingleton = Live . Set.singleton . unAddress +liveSingleton :: location -> Live location value +liveSingleton = Live . Set.singleton -- | Insert an address into a 'Live' set. -liveInsert :: Ord location => Address location value -> Live location value -> Live location value -liveInsert addr = Live . Set.insert (unAddress addr) . unLive +liveInsert :: Ord location => location -> Live location value -> Live location value +liveInsert addr = Live . Set.insert addr . unLive -- | Delete an address from a 'Live' set, if present. -liveDelete :: Ord location => Address location value -> Live location value -> Live location value -liveDelete addr = Live . Set.delete (unAddress addr) . unLive +liveDelete :: Ord location => location -> Live location value -> Live location value +liveDelete addr = Live . Set.delete addr . unLive -- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set. liveDifference :: Ord location => Live location value -> Live location value -> Live location value liveDifference = fmap Live . (Set.difference `on` unLive) -- | Test whether an 'Address' is in a 'Live' set. -liveMember :: Ord location => Address location value -> Live location value -> Bool -liveMember addr = Set.member (unAddress addr) . unLive +liveMember :: Ord location => location -> Live location value -> Bool +liveMember addr = Set.member addr . unLive -- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty. -liveSplit :: Live location value -> Maybe (Address location value, Live location value) -liveSplit = fmap (bimap Address Live) . Set.minView . unLive +liveSplit :: Live location value -> Maybe (location, Live location value) +liveSplit = fmap (fmap Live) . Set.minView . unLive instance Show location => Show (Live location value) where From aad72ca048f12aac35d022a3cc25082606091d0a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:23:17 -0400 Subject: [PATCH 07/88] Missed a couple. --- src/Control/Abstract/Heap.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index def51bb2a..092a91b45 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -82,7 +82,7 @@ letrec :: ( Member (Allocator location value) effects -> Evaluator location value effects (value, Address location value) letrec name body = do addr <- lookupOrAlloc name - v <- localEnv (insert name addr) body + v <- localEnv (insert name (unAddress addr)) body assign addr v pure (v, addr) @@ -96,7 +96,7 @@ letrec' :: ( Member (Allocator location value) effects letrec' name body = do addr <- lookupOrAlloc name v <- localEnv id (body addr) - v <$ modifyEnv (insert name addr) + v <$ modifyEnv (insert name (unAddress addr)) -- | Look up and dereference the given 'Name', throwing an exception for free variables. From 35a305fa76fe5c5a87d678c9e96b9324a7b137e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:25:00 -0400 Subject: [PATCH 08/88] :fire: fullEnvironment. --- src/Control/Abstract/Environment.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index f207e57ae..cc6a13644 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -7,7 +7,6 @@ module Control.Abstract.Environment , withEnv , defaultEnvironment , withDefaultEnvironment -, fullEnvironment , localEnv , localize , lookupEnv @@ -52,11 +51,6 @@ defaultEnvironment = ask withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a withDefaultEnvironment e = local (const e) --- | Obtain an environment that is the composition of the current and default environments. --- Useful for debugging. -fullEnvironment :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value effects (Environment location) -fullEnvironment = mergeEnvs <$> getEnv <*> defaultEnvironment - -- | Run an action with a locally-modified environment. localEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects a -> Evaluator location value effects a localEnv f a = do From 2f16ed9585add87772ea29642f23d10d7a33c79e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:28:02 -0400 Subject: [PATCH 09/88] defaultEnvironment is implementation detail. --- src/Control/Abstract/Environment.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index cc6a13644..3be4c214f 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -5,7 +5,6 @@ module Control.Abstract.Environment , putEnv , modifyEnv , withEnv -, defaultEnvironment , withDefaultEnvironment , localEnv , localize @@ -42,10 +41,6 @@ withEnv :: Member (State (Environment location)) effects => Environment location withEnv = localState . const --- | Retrieve the default environment. -defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location) -defaultEnvironment = ask - -- | Set the default environment for the lifetime of an action. -- Usually only invoked in a top-level evaluation function. withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a @@ -78,6 +73,11 @@ reinterpretEnv :: Evaluator location value (Env location ': effects) a -> Evalua reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) +-- | Retrieve the default environment. +defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location) +defaultEnvironment = ask + + -- | Errors involving the environment. data EnvironmentError location return where FreeVariable :: Name -> EnvironmentError location location From 78c32db27129f1a2618dc239811af57f95be9b31 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:31:12 -0400 Subject: [PATCH 10/88] Close over the default environment. --- src/Control/Abstract/Environment.hs | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 3be4c214f..fc1422f7a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -66,16 +66,11 @@ data Env location return where Lookup :: Name -> Env location (Maybe location) -runEnv :: (Member (Reader (Environment location)) effects, Member (State (Environment location)) effects) => Evaluator location value (Env location ': effects) a -> Evaluator location value effects a -runEnv = interpret (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) +runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a +runEnv defaultEnvironment = interpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv) -reinterpretEnv :: Evaluator location value (Env location ': effects) a -> Evaluator location value (Reader (Environment location) ': State (Environment location) ': effects) a -reinterpretEnv = reinterpret2 (\ (Lookup name) -> (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)) - - --- | Retrieve the default environment. -defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location) -defaultEnvironment = ask +reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a +reinterpretEnv defaultEnvironment = reinterpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv) -- | Errors involving the environment. From d2e9974a0cd1b674eae790a72aceefbfe9898777 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:31:56 -0400 Subject: [PATCH 11/88] :fire: withDefaultEnvironment. --- src/Control/Abstract/Environment.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index fc1422f7a..dd5cf1683 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -5,7 +5,6 @@ module Control.Abstract.Environment , putEnv , modifyEnv , withEnv -, withDefaultEnvironment , localEnv , localize , lookupEnv @@ -41,11 +40,6 @@ withEnv :: Member (State (Environment location)) effects => Environment location withEnv = localState . const --- | Set the default environment for the lifetime of an action. --- Usually only invoked in a top-level evaluation function. -withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a -withDefaultEnvironment e = local (const e) - -- | Run an action with a locally-modified environment. localEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects a -> Evaluator location value effects a localEnv f a = do From 71dba01c1db413ce7ad07d074e03fc79343f469f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:34:12 -0400 Subject: [PATCH 12/88] =?UTF-8?q?Don=E2=80=99t=20use=20localize.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 893da6b67..d9733e3e6 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -167,7 +167,7 @@ forLoop :: ( AbstractValue location value effects -> Evaluator location value effects value -- ^ Body -> Evaluator location value effects value forLoop initial cond step body = - localize (initial *> while cond (body *> step)) + localEnv id (initial *> while cond (body *> step)) -- | The fundamental looping primitive, built on top of 'ifthenelse'. while :: AbstractValue location value effects From 6f89e256280362d693cd75e3e65c85787b963bc7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 17:34:26 -0400 Subject: [PATCH 13/88] :fire: localize. --- src/Control/Abstract/Environment.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index dd5cf1683..f4a884f45 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -6,7 +6,6 @@ module Control.Abstract.Environment , modifyEnv , withEnv , localEnv -, localize , lookupEnv , Env(..) , runEnv @@ -47,10 +46,6 @@ localEnv f a = do result <- a result <$ modifyEnv Env.pop --- | Run a computation in a new local environment. -localize :: Member (State (Environment location)) effects => Evaluator location value effects a -> Evaluator location value effects a -localize = localEnv id - -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env location) effects => Name -> Evaluator location value effects (Maybe (Address location value)) lookupEnv name = fmap Address <$> send (Lookup name) From a1d05dcd3d94e1848668642750fcb5e9ecf06871 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 18:41:07 -0400 Subject: [PATCH 14/88] Rename Env.bind to Env.intersect. --- src/Data/Abstract/Environment.hs | 6 +++--- src/Data/Abstract/Value.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 19a9d8858..6cc11f42a 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -1,7 +1,6 @@ module Data.Abstract.Environment ( Environment(..) , addresses - , bind , delete , head , emptyEnv @@ -10,6 +9,7 @@ module Data.Abstract.Environment , insert , lookup , names + , intersect , overwrite , pairs , unpairs @@ -99,8 +99,8 @@ trim :: Environment location -> Environment location trim (Environment (a :| as)) = Environment (a :| filtered) where filtered = filter (not . Map.null) as -bind :: Foldable t => t Name -> Environment location -> Environment location -bind names env = unpairs (mapMaybe lookupName (toList names)) +intersect :: Foldable t => t Name -> Environment location -> Environment location +intersect names env = unpairs (mapMaybe lookupName (toList names)) where lookupName name = (,) name <$> lookup name env diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index b15db00f7..430d88cee 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -72,7 +72,7 @@ instance ( Coercible body (Eff effects) packageInfo <- currentPackage moduleInfo <- currentModule i <- fresh - Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv + Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.intersect (foldr Set.delete freeVariables parameters) <$> getEnv call op params = do case op of From 6b4d7db19262b9482314247329ca577a75b07767 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 18:43:10 -0400 Subject: [PATCH 15/88] Add a constructor to bind names. --- src/Control/Abstract/Environment.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index f4a884f45..1ec388b5c 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeOperators #-} module Control.Abstract.Environment ( Environment , getEnv @@ -52,14 +52,19 @@ lookupEnv name = fmap Address <$> send (Lookup name) data Env location return where - Lookup :: Name -> Env location (Maybe location) + Lookup :: Name -> Env location (Maybe location) + Bind :: Name -> location -> Env location () runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a -runEnv defaultEnvironment = interpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv) +runEnv defaultEnvironment = interpret $ \case + Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv + Bind name addr -> modifyEnv (Env.insert name addr) reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a -reinterpretEnv defaultEnvironment = reinterpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv) +reinterpretEnv defaultEnvironment = reinterpret $ \case + Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv + Bind name addr -> modifyEnv (Env.insert name addr) -- | Errors involving the environment. From cebcfab528e51641ac06e638c56ba9ee64d31cc1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 18:47:32 -0400 Subject: [PATCH 16/88] Define a smart constructor to bind names to addresses. --- src/Control/Abstract/Environment.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 1ec388b5c..ce535d370 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -7,6 +7,7 @@ module Control.Abstract.Environment , withEnv , localEnv , lookupEnv +, bind , Env(..) , runEnv , reinterpretEnv @@ -50,6 +51,10 @@ localEnv f a = do lookupEnv :: Member (Env location) effects => Name -> Evaluator location value effects (Maybe (Address location value)) lookupEnv name = fmap Address <$> send (Lookup name) +-- | Bind a 'Name' to an 'Address' in the environment. +bind :: Member (Env location) effects => Name -> Address location value -> Evaluator location value effects () +bind name addr = send (Bind name (unAddress addr)) + data Env location return where Lookup :: Name -> Env location (Maybe location) From 39d2a568de5c6714f6c8c81e2cff1d9226c715b4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 18:48:45 -0400 Subject: [PATCH 17/88] =?UTF-8?q?Use=20bind=20wherever=20we=E2=80=99re=20i?= =?UTF-8?q?nserting=20names=20manually.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Heap.hs | 2 +- src/Control/Abstract/Primitive.hs | 7 +++---- src/Data/Syntax/Declaration.hs | 10 ++++------ src/Data/Syntax/Statement.hs | 2 +- src/Language/TypeScript/Syntax.hs | 4 ++-- 5 files changed, 11 insertions(+), 14 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 092a91b45..9084315a5 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -96,7 +96,7 @@ letrec' :: ( Member (Allocator location value) effects letrec' name body = do addr <- lookupOrAlloc name v <- localEnv id (body addr) - v <$ modifyEnv (insert name (unAddress addr)) + v <$ bind name addr -- | Look up and dereference the given 'Name', throwing an exception for free variables. diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index f0b280bec..7b5fca148 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -15,9 +15,9 @@ import Prologue builtin :: ( HasCallStack , Member (Allocator location value) effects + , Member (Env location) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location , Reducer value (Cell location value) @@ -28,7 +28,7 @@ builtin :: ( HasCallStack builtin s def = withCurrentCallStack callStack $ do let name' = name (pack ("__semantic_" <> s)) addr <- alloc name' - modifyEnv (insert name' addr) + bind name' addr def >>= assign addr lambda :: (AbstractFunction location value effects, Member Fresh effects) @@ -41,12 +41,11 @@ lambda body = do defineBuiltins :: ( AbstractValue location value effects , HasCallStack , Member (Allocator location value) effects + , Member (Env location) effects , Member Fresh effects - , Member (Reader (Environment location)) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects , Member Trace effects , Ord location diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 7b3d618bb..67f0a3941 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -27,8 +27,7 @@ instance Evaluatable Function where eval Function{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName) (v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody)) - modifyEnv (Env.insert name addr) - pure (Rval v) + Rval v <$ bind name addr where paramNames = foldMap (freeVariables . subterm) instance Declarations a => Declarations (Function a) where @@ -53,8 +52,7 @@ instance Evaluatable Method where eval Method{..} = do name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName) (v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody)) - modifyEnv (Env.insert name addr) - pure (Rval v) + Rval v <$ bind name addr where paramNames = foldMap (freeVariables . subterm) @@ -187,7 +185,7 @@ instance Evaluatable Class where void $ subtermValue classBody classEnv <- Env.head <$> getEnv klass name supers classEnv - Rval <$> (v <$ modifyEnv (Env.insert name addr)) + Rval v <$ bind name addr -- | A decorator in Python data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a } @@ -278,7 +276,7 @@ instance Evaluatable TypeAlias where v <- subtermValue typeAliasKind addr <- lookupOrAlloc name assign addr v - Rval <$> (modifyEnv (Env.insert name addr) $> v) + Rval v <$> bind name addr instance Declarations a => Declarations (TypeAlias a) where declaredName TypeAlias{..} = declaredName typeAliasIdentifier diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index aee3158db..e772d2153 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -119,7 +119,7 @@ instance Evaluatable Assignment where LvalLocal nam -> do addr <- lookupOrAlloc nam assign addr rhs - modifyEnv (Env.insert nam addr) + bind name addr LvalMember _ _ -> -- we don't yet support mutable object properties: pure () diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 8fa467554..cac08b9c5 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -272,7 +272,7 @@ instance Evaluatable DefaultExport where addr <- lookupOrAlloc name assign addr v addExport name name Nothing - void $ modifyEnv (Env.insert name addr) + bind name addr Nothing -> throwEvalError DefaultExportError pure (Rval unit) @@ -852,7 +852,7 @@ instance Evaluatable AbstractClass where void $ subtermValue classBody classEnv <- Env.head <$> getEnv klass name supers classEnv - Rval <$> (v <$ modifyEnv (Env.insert name addr)) + Rval v <$ bind name addr data JsxElement a = JsxElement { _jsxOpeningElement :: !a, _jsxElements :: ![a], _jsxClosingElement :: !a } From df1e39bc25f8954cf0958269405848a5ffef4c83 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:40:41 -0400 Subject: [PATCH 18/88] Add push/pop constructors. --- src/Control/Abstract/Environment.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index ce535d370..a5340f4e4 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -59,17 +59,23 @@ bind name addr = send (Bind name (unAddress addr)) data Env location return where Lookup :: Name -> Env location (Maybe location) Bind :: Name -> location -> Env location () + Push :: Env location () + Pop :: Env location () runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a runEnv defaultEnvironment = interpret $ \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) + Push -> modifyEnv Env.push + Pop -> modifyEnv Env.pop reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a reinterpretEnv defaultEnvironment = reinterpret $ \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) + Push -> modifyEnv Env.push + Pop -> modifyEnv Env.pop -- | Errors involving the environment. From 0ba8046f28481d1575394430017ee644fe6d49c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:48:27 -0400 Subject: [PATCH 19/88] Define a helper to push a local scope. --- src/Control/Abstract/Environment.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a5340f4e4..5e79bacde 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeOperators #-} +{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Environment ( Environment , getEnv @@ -6,6 +6,7 @@ module Control.Abstract.Environment , modifyEnv , withEnv , localEnv +, locally , lookupEnv , bind , Env(..) @@ -19,7 +20,8 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Address -import Data.Abstract.Environment as Env +import Data.Abstract.Environment (Environment) +import qualified Data.Abstract.Environment as Env import Data.Abstract.Name import Prologue @@ -47,6 +49,12 @@ localEnv f a = do result <- a result <$ modifyEnv Env.pop +locally :: forall location value effects a . Member (Env location) effects => Evaluator location value effects a -> Evaluator location value effects a +locally a = do + send (Push @location) + a' <- a + a' <$ send (Pop @location) + -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env location) effects => Name -> Evaluator location value effects (Maybe (Address location value)) lookupEnv name = fmap Address <$> send (Lookup name) From 43f774e0c3d070b97e0c52587c26d088d7392733 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:49:53 -0400 Subject: [PATCH 20/88] Use locally in the Heap actions. --- src/Control/Abstract/Heap.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 9084315a5..c913f2969 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -24,7 +24,6 @@ import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Monad.Effect.Internal import Data.Abstract.Address -import Data.Abstract.Environment import Data.Abstract.Heap import Data.Abstract.Name import Data.Semigroup.Reducer @@ -82,7 +81,9 @@ letrec :: ( Member (Allocator location value) effects -> Evaluator location value effects (value, Address location value) letrec name body = do addr <- lookupOrAlloc name - v <- localEnv (insert name (unAddress addr)) body + v <- locally $ do + bind name addr + body assign addr v pure (v, addr) @@ -95,7 +96,7 @@ letrec' :: ( Member (Allocator location value) effects -> Evaluator location value effects value letrec' name body = do addr <- lookupOrAlloc name - v <- localEnv id (body addr) + v <- locally (body addr) v <$ bind name addr From a878f85bdb6cdabc05a2f01e8e9aa6e36e69cc90 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:52:57 -0400 Subject: [PATCH 21/88] Hide an export. --- src/Control/Abstract.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index 681a3dd13..d33e384ff 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -5,7 +5,7 @@ module Control.Abstract import Control.Abstract.Addressable as X import Control.Abstract.Configuration as X import Control.Abstract.Context as X -import Control.Abstract.Environment as X +import Control.Abstract.Environment as X hiding (Lookup) import Control.Abstract.Evaluator as X import Control.Abstract.Exports as X import Control.Abstract.Heap as X From 4feee938399eb7d1ef23e906d935ad1cc3c93940 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 20:53:03 -0400 Subject: [PATCH 22/88] Use the Env effect. --- src/Control/Abstract/Value.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d9733e3e6..313a8072b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -220,7 +220,7 @@ evaluateInScopedEnv scopedEnvTerm term = do -- | Evaluates a 'Value' returning the referenced value value :: ( AbstractValue location value effects , Member (Allocator location value) effects - , Member (Reader (Environment location)) effects + , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects , Member (State (Environment location)) effects ) @@ -233,7 +233,7 @@ value (Rval val) = pure val -- | Evaluates a 'Subterm' to its rval subtermValue :: ( AbstractValue location value effects , Member (Allocator location value) effects - , Member (Reader (Environment location)) effects + , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects , Member (State (Environment location)) effects ) From 7c7204eec828311333cca083ef4dedf72dff3b62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:05:52 -0400 Subject: [PATCH 23/88] Define a bindAll operation. --- src/Control/Abstract/Environment.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 5e79bacde..8b7e081d0 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -9,6 +9,7 @@ module Control.Abstract.Environment , locally , lookupEnv , bind +, bindAll , Env(..) , runEnv , reinterpretEnv @@ -63,6 +64,9 @@ lookupEnv name = fmap Address <$> send (Lookup name) bind :: Member (Env location) effects => Name -> Address location value -> Evaluator location value effects () bind name addr = send (Bind name (unAddress addr)) +bindAll :: Member (Env location) effects => Environment location -> Evaluator location value effects () +bindAll = foldr ((>>) . uncurry bind . second Address) (pure ()) . Env.pairs + data Env location return where Lookup :: Name -> Env location (Maybe location) From b73de43e9775723aff4d82be45aa02ad829c041e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:09:00 -0400 Subject: [PATCH 24/88] Add a constructor for closure over the environment. --- src/Control/Abstract/Environment.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 8b7e081d0..efd89b1fa 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -10,6 +10,7 @@ module Control.Abstract.Environment , lookupEnv , bind , bindAll +, close , Env(..) , runEnv , reinterpretEnv @@ -67,10 +68,14 @@ bind name addr = send (Bind name (unAddress addr)) bindAll :: Member (Env location) effects => Environment location -> Evaluator location value effects () bindAll = foldr ((>>) . uncurry bind . second Address) (pure ()) . Env.pairs +close :: Member (Env location) effects => Set Name -> Evaluator location value effects (Environment location) +close = send . Close + data Env location return where Lookup :: Name -> Env location (Maybe location) Bind :: Name -> location -> Env location () + Close :: Set Name -> Env location (Environment location) Push :: Env location () Pop :: Env location () @@ -79,6 +84,7 @@ runEnv :: Member (State (Environment location)) effects => Environment location runEnv defaultEnvironment = interpret $ \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) + Close names -> Env.intersect names <$> getEnv Push -> modifyEnv Env.push Pop -> modifyEnv Env.pop @@ -86,6 +92,7 @@ reinterpretEnv :: Environment location -> Evaluator location value (Env location reinterpretEnv defaultEnvironment = reinterpret $ \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) + Close names -> Env.intersect names <$> getEnv Push -> modifyEnv Env.push Pop -> modifyEnv Env.pop From 02d021fed5349fa8b37d6c8770c9a1a01083e526 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:11:10 -0400 Subject: [PATCH 25/88] Add a single handler which we interpret/reinterpret. --- src/Control/Abstract/Environment.hs | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index efd89b1fa..50eba859a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -79,22 +79,19 @@ data Env location return where Push :: Env location () Pop :: Env location () +handleEnv :: Member (State (Environment location)) effects => Environment location -> Env location result -> Evaluator location value effects result +handleEnv defaultEnvironment = \case + Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv + Bind name addr -> modifyEnv (Env.insert name addr) + Close names -> Env.intersect names <$> getEnv + Push -> modifyEnv Env.push + Pop -> modifyEnv Env.pop runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a -runEnv defaultEnvironment = interpret $ \case - Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv - Bind name addr -> modifyEnv (Env.insert name addr) - Close names -> Env.intersect names <$> getEnv - Push -> modifyEnv Env.push - Pop -> modifyEnv Env.pop +runEnv defaultEnvironment = interpret (handleEnv defaultEnvironment) reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a -reinterpretEnv defaultEnvironment = reinterpret $ \case - Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv - Bind name addr -> modifyEnv (Env.insert name addr) - Close names -> Env.intersect names <$> getEnv - Push -> modifyEnv Env.push - Pop -> modifyEnv Env.pop +reinterpretEnv defaultEnvironment = reinterpret (handleEnv defaultEnvironment) -- | Errors involving the environment. From f8e31c87d64ac0e36daa1247b529aa4ebc202be0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:11:49 -0400 Subject: [PATCH 26/88] :fire: a redundant import. --- src/Control/Abstract/Primitive.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 7b5fca148..20b8349dc 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -6,7 +6,6 @@ import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap import Control.Abstract.Value -import Data.Abstract.Environment import Data.Abstract.Name import Data.ByteString.Char8 (pack, unpack) import Data.Semigroup.Reducer hiding (unit) From 213841576ddfeb8e412f2d8ce8700886ac2cbce0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:12:03 -0400 Subject: [PATCH 27/88] Bind locally in evaluateScopedEnv. --- src/Control/Abstract/Value.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 313a8072b..bee66bcef 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -19,7 +19,7 @@ import Control.Abstract.Addressable import Control.Abstract.Environment import Control.Abstract.Evaluator import Control.Abstract.Heap -import Data.Abstract.Address (Address) +import Data.Abstract.Address (Address(..)) import Data.Abstract.Environment as Env import Data.Abstract.Live (Live) import Data.Abstract.Name @@ -207,14 +207,14 @@ makeNamespace name addr super = do -- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'. evaluateInScopedEnv :: ( AbstractValue location value effects - , Member (State (Environment location)) effects + , Member (Env location) effects ) => Evaluator location value effects value -> Evaluator location value effects value -> Evaluator location value effects value evaluateInScopedEnv scopedEnvTerm term = do scopedEnv <- scopedEnvTerm >>= scopedEnvironment - maybe term (flip localEnv term . mergeEnvs) scopedEnv + maybe term (\ env -> locally $ bindAll env >> term) scopedEnv -- | Evaluates a 'Value' returning the referenced value @@ -222,7 +222,6 @@ value :: ( AbstractValue location value effects , Member (Allocator location value) effects , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects ) => ValueRef value -> Evaluator location value effects value @@ -235,7 +234,6 @@ subtermValue :: ( AbstractValue location value effects , Member (Allocator location value) effects , Member (Env location) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects ) => Subterm term (Evaluator location value effects (ValueRef value)) -> Evaluator location value effects value From 4d62cb3f9181dc67d7bfcacc2da76e5d9d7a8ecd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:15:26 -0400 Subject: [PATCH 28/88] Use Env in Value. --- src/Data/Abstract/Value.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 430d88cee..0aac2151b 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -2,6 +2,7 @@ module Data.Abstract.Value where import Control.Abstract +import Data.Abstract.Address import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs) import qualified Data.Abstract.Environment as Env import Data.Abstract.Name @@ -56,12 +57,12 @@ instance AbstractHole (Value location body) where instance ( Coercible body (Eff effects) , Member (Allocator location (Value location body)) effects + , Member (Env location) effects , Member Fresh effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable (ValueError location body)) effects , Member (Return (Value location body)) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) (Value location body))) effects , Ord location , Reducer (Value location body) (Cell location (Value location body)) @@ -72,7 +73,7 @@ instance ( Coercible body (Eff effects) packageInfo <- currentPackage moduleInfo <- currentModule i <- fresh - Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.intersect (foldr Set.delete freeVariables parameters) <$> getEnv + Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) <$> close (foldr Set.delete freeVariables parameters) call op params = do case op of @@ -81,11 +82,11 @@ instance ( Coercible body (Eff effects) -- charge them to the closure's origin. withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do bindings <- foldr (\ (name, param) rest -> do - v <- param - a <- alloc name - assign a v - Env.insert name a <$> rest) (pure env) (zip names params) - localEnv (mergeEnvs bindings) (raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value) + value <- param + addr <- alloc name + assign addr value + Env.insert name (unAddress addr) <$> rest) (pure env) (zip names params) + locally (bindAll bindings >> raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value) _ -> throwValueError (CallError op) @@ -109,14 +110,13 @@ instance Show location => AbstractIntro (Value location body) where -- | Construct a 'Value' wrapping the value arguments (if any). instance ( Coercible body (Eff effects) , Member (Allocator location (Value location body)) effects + , Member (Env location) effects , Member Fresh effects , Member (LoopControl (Value location body)) effects - , Member (Reader (Environment location)) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Resumable (ValueError location body)) effects , Member (Return (Value location body)) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) (Value location body))) effects , Ord location , Reducer (Value location body) (Cell location (Value location body)) From 95b54332338a067b075733a801b1afaaa65f74de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:16:44 -0400 Subject: [PATCH 29/88] Use Env in Type. --- src/Data/Abstract/Type.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 9d7e6ed54..41b3dde23 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -8,6 +8,7 @@ module Data.Abstract.Type ) where import Control.Abstract +import Data.Abstract.Address import Data.Abstract.Environment as Env import Data.Semigroup.Foldable (foldMap1) import Data.Semigroup.Reducer (Reducer) @@ -117,10 +118,10 @@ instance AbstractIntro Type where instance ( Member (Allocator location Type) effects + , Member (Env location) effects , Member Fresh effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) Type)) effects , Ord location , Reducer Type (Cell location Type) @@ -128,11 +129,11 @@ instance ( Member (Allocator location Type) effects => AbstractFunction location Type effects where closure names _ body = do (env, tvars) <- foldr (\ name rest -> do - a <- alloc name + addr <- alloc name tvar <- Var <$> fresh - assign a tvar - bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names - (zeroOrMoreProduct tvars :->) <$> localEnv (mergeEnvs env) (body `catchReturn` \ (Return value) -> pure value) + assign addr tvar + bimap (Env.insert name (unAddress addr)) (tvar :) <$> rest) (pure (emptyEnv, [])) names + (zeroOrMoreProduct tvars :->) <$> locally (bindAll env >> body `catchReturn` \ (Return value) -> pure value) call op params = do tvar <- fresh @@ -146,11 +147,11 @@ instance ( Member (Allocator location Type) effects -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Member (Allocator location Type) effects + , Member (Env location) effects , Member Fresh effects , Member NonDet effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) Type)) effects , Ord location , Reducer Type (Cell location Type) From 5110a936a006f5011bddee808c268e6224d3aeff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:21:43 -0400 Subject: [PATCH 30/88] :fire: the value parameter to Live. --- src/Analysis/Abstract/Caching.hs | 4 ++-- src/Analysis/Abstract/Collecting.hs | 10 +++++----- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Configuration.hs | 2 +- src/Control/Abstract/Roots.hs | 4 ++-- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Configuration.hs | 2 +- src/Data/Abstract/Environment.hs | 4 ++-- src/Data/Abstract/Heap.hs | 2 +- src/Data/Abstract/Live.hs | 18 +++++++++--------- 10 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 13e76a502..07b7402ef 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -60,7 +60,7 @@ cachingTerms :: ( Cacheable term location (Cell location) value , Corecursive term , Member NonDet effects , Member (Reader (Cache term location (Cell location) value)) effects - , Member (Reader (Live location value)) effects + , Member (Reader (Live location)) effects , Member (State (Cache term location (Cell location) value)) effects , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects @@ -83,7 +83,7 @@ convergingModules :: ( AbstractValue location value effects , Member NonDet effects , Member (Reader (Cache term location (Cell location) value)) effects , Member (Reader (Environment location)) effects - , Member (Reader (Live location value)) effects + , Member (Reader (Live location)) effects , Member (Resumable (EnvironmentError location)) effects , Member (State (Cache term location (Cell location) value)) effects , Member (State (Environment location)) effects diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 2b3a33353..521574d6e 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -12,7 +12,7 @@ import Prologue -- | An analysis performing GC after every instruction. collectingTerms :: ( Foldable (Cell location) - , Member (Reader (Live location value)) effects + , Member (Reader (Live location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location , ValueRoots location value @@ -29,7 +29,7 @@ gc :: ( Ord location , Foldable (Cell location) , ValueRoots location value ) - => Live location value -- ^ The set of addresses to consider rooted. + => Live location -- ^ The set of addresses to consider rooted. -> Heap location (Cell location) value -- ^ A heap to collect unreachable addresses within. -> Heap location (Cell location) value -- ^ A garbage-collected heap. gc roots heap = heapRestrict heap (reachable roots heap) @@ -39,9 +39,9 @@ reachable :: ( Ord location , Foldable (Cell location) , ValueRoots location value ) - => Live location value -- ^ The set of root addresses. + => Live location -- ^ The set of root addresses. -> Heap location (Cell location) value -- ^ The heap to trace addresses through. - -> Live location value -- ^ The set of addresses reachable from the root set. + -> Live location -- ^ The set of addresses reachable from the root set. reachable roots heap = go mempty roots where go seen set = case liveSplit set of Nothing -> seen @@ -50,5 +50,5 @@ reachable roots heap = go mempty roots _ -> seen) -providingLiveSet :: Effectful (m location value) => m location value (Reader (Live location value) ': effects) a -> m location value effects a +providingLiveSet :: Effectful (m location value) => m location value (Reader (Live location) ': effects) a -> m location value effects a providingLiveSet = runReader lowerBound diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 62d43d152..d0919b42b 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -13,7 +13,7 @@ import Prologue -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Corecursive term - , Member (Reader (Live location value)) effects + , Member (Reader (Live location)) effects , Member (State (Environment location)) effects , Member (State (Heap location (Cell location) value)) effects , Member (Writer (trace (Configuration term location (Cell location) value))) effects diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 4ff37c9c3..42bb8eec2 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator import Data.Abstract.Configuration -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live location value)) effects, Member (State (Environment location)) effects, Member (State (Heap location (Cell location) value)) effects) => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value) +getConfiguration :: (Member (Reader (Live location)) effects, Member (State (Environment location)) effects, Member (State (Heap location (Cell location) value)) effects) => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap diff --git a/src/Control/Abstract/Roots.hs b/src/Control/Abstract/Roots.hs index 375940ef4..4c5277258 100644 --- a/src/Control/Abstract/Roots.hs +++ b/src/Control/Abstract/Roots.hs @@ -9,9 +9,9 @@ import Data.Abstract.Live import Prologue -- | Retrieve the local 'Live' set. -askRoots :: Member (Reader (Live location value)) effects => Evaluator location value effects (Live location value) +askRoots :: Member (Reader (Live location)) effects => Evaluator location value effects (Live location) askRoots = ask -- | Run a computation with the given 'Live' set added to the local root set. -extraRoots :: (Member (Reader (Live location value)) effects, Ord location) => Live location value -> Evaluator location value effects a -> Evaluator location value effects a +extraRoots :: (Member (Reader (Live location)) effects, Ord location) => Live location -> Evaluator location value effects a -> Evaluator location value effects a extraRoots roots = local (<> roots) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index bee66bcef..0e36c279c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -243,4 +243,4 @@ subtermValue = value <=< subtermRef -- | Value types, e.g. closures, which can root a set of addresses. class ValueRoots location value where -- | Compute the set of addresses rooted by a given value. - valueRoots :: value -> Live location value + valueRoots :: value -> Live location diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 72913421b..fe8e1f9fa 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -7,7 +7,7 @@ import Data.Abstract.Live -- | A single point in a program’s execution. data Configuration term location cell value = Configuration { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live location value -- ^ The set of rooted addresses. + , configurationRoots :: Live location -- ^ The set of rooted addresses. , configurationEnvironment :: Environment location -- ^ The environment binding any free variables in 'configurationTerm'. , configurationHeap :: Heap location cell value -- ^ The heap of values. } diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index 6cc11f42a..20f801c6e 100644 --- a/src/Data/Abstract/Environment.hs +++ b/src/Data/Abstract/Environment.hs @@ -117,10 +117,10 @@ overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs -- | Retrieve the 'Live' set of addresses to which the given free variable names are bound. -- -- Unbound names are silently dropped. -roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location value +roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location roots env = foldMap (maybe mempty liveSingleton . flip lookup env) -addresses :: Ord location => Environment location -> Live location value +addresses :: Ord location => Environment location -> Live location addresses = fromAddresses . map snd . pairs diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 0a878d03b..9d3e251e1 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -33,7 +33,7 @@ heapSize :: Heap location cell value -> Int heapSize = Monoidal.size . unHeap -- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest). -heapRestrict :: Ord location => Heap location cell value -> Live location value -> Heap location cell value +heapRestrict :: Ord location => Heap location cell value -> Live location -> Heap location cell value heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index 345d9f873..a1b0fde05 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -6,36 +6,36 @@ import Data.Set as Set import Prologue -- | A set of live addresses (whether roots or reachable). -newtype Live location value = Live { unLive :: Set location } +newtype Live location = Live { unLive :: Set location } deriving (Eq, Lower, Monoid, Ord, Semigroup) -fromAddresses :: (Foldable t, Ord location) => t location -> Live location value +fromAddresses :: (Foldable t, Ord location) => t location -> Live location fromAddresses = Prologue.foldr liveInsert lowerBound -- | Construct a 'Live' set containing only the given address. -liveSingleton :: location -> Live location value +liveSingleton :: location -> Live location liveSingleton = Live . Set.singleton -- | Insert an address into a 'Live' set. -liveInsert :: Ord location => location -> Live location value -> Live location value +liveInsert :: Ord location => location -> Live location -> Live location liveInsert addr = Live . Set.insert addr . unLive -- | Delete an address from a 'Live' set, if present. -liveDelete :: Ord location => location -> Live location value -> Live location value +liveDelete :: Ord location => location -> Live location -> Live location liveDelete addr = Live . Set.delete addr . unLive -- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set. -liveDifference :: Ord location => Live location value -> Live location value -> Live location value +liveDifference :: Ord location => Live location -> Live location -> Live location liveDifference = fmap Live . (Set.difference `on` unLive) -- | Test whether an 'Address' is in a 'Live' set. -liveMember :: Ord location => location -> Live location value -> Bool +liveMember :: Ord location => location -> Live location -> Bool liveMember addr = Set.member addr . unLive -- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty. -liveSplit :: Live location value -> Maybe (location, Live location value) +liveSplit :: Live location -> Maybe (location, Live location) liveSplit = fmap (fmap Live) . Set.minView . unLive -instance Show location => Show (Live location value) where +instance Show location => Show (Live location) where showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive From 65d6e268d1a5d2e73741b1366b0144b4044f1b63 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:22:20 -0400 Subject: [PATCH 31/88] Correct a doc comment. --- src/Data/Abstract/Live.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index a1b0fde05..38b103cac 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -28,7 +28,7 @@ liveDelete addr = Live . Set.delete addr . unLive liveDifference :: Ord location => Live location -> Live location -> Live location liveDifference = fmap Live . (Set.difference `on` unLive) --- | Test whether an 'Address' is in a 'Live' set. +-- | Test whether an address is in a 'Live' set. liveMember :: Ord location => location -> Live location -> Bool liveMember addr = Set.member addr . unLive From 9a8acdc32875a85ba34c70cd3c4b51806a682206 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:23:50 -0400 Subject: [PATCH 32/88] Wrap an Address. --- src/Analysis/Abstract/Collecting.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 521574d6e..87f0f2d42 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -5,6 +5,7 @@ module Analysis.Abstract.Collecting ) where import Control.Abstract +import Data.Abstract.Address import Data.Abstract.Heap import Data.Abstract.Live import Data.Semilattice.Lower @@ -45,7 +46,7 @@ reachable :: ( Ord location reachable roots heap = go mempty roots where go seen set = case liveSplit set of Nothing -> seen - Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of + Just (a, as) -> go (liveInsert a seen) (case heapLookupAll (Address a) heap of Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen _ -> seen) From d4d5cc04d5b82cb224c3c5c2fd9946e8efcf3088 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 21:41:04 -0400 Subject: [PATCH 33/88] =?UTF-8?q?Don=E2=80=99t=20provide=20a=20Reader=20fo?= =?UTF-8?q?r=20the=20default=20environment.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Evaluating.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3cc429c3d..47e89d01d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,7 +23,6 @@ deriving instance (Show (Cell location value), Show location, Show value) => Sho evaluating :: Evaluator location value ( Fail ': Fresh - ': Reader (Environment location) ': State (Environment location) ': State (Heap location (Cell location) value) ': State (ModuleTable (Maybe (Environment location, value))) @@ -36,6 +35,5 @@ evaluating . runState lowerBound -- State (ModuleTable (Maybe (Environment location, value))) . runState lowerBound -- State (Heap location (Cell location) value) . runState lowerBound -- State (Environment location) - . runReader lowerBound -- Reader (Environment location) . runFresh 0 . runFail From c58d0df57fd5b4ab9b1c5f0a8a36f1ce2f49750d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 29 May 2018 22:03:54 -0400 Subject: [PATCH 34/88] Run the Env effect. --- src/Data/Abstract/Evaluatable.hs | 43 +++++++++++++++++--------------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 8b87f5dc6..37b3403af 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -56,9 +56,9 @@ type EvaluatableConstraints location term value effects = , Declarations term , FreeVariables term , Member (Allocator location value) effects + , Member (Env location) effects , Member (LoopControl value) effects , Member (Modules location value) effects - , Member (Reader (Environment location)) effects , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Reader Span) effects @@ -67,7 +67,6 @@ type EvaluatableConstraints location term value effects = , Member (Resumable ResolutionError) effects , Member (Resumable (Unspecialized value)) effects , Member (Return value) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member (State (Heap location (Cell location) value)) effects , Member Trace effects @@ -77,14 +76,13 @@ type EvaluatableConstraints location term value effects = -- | Evaluate a given package. -evaluatePackageWith :: forall location term value inner outer - -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out? - . ( Addressable location (Reader ModuleInfo ': Modules location value ': Reader Span ': Reader PackageInfo ': outer) +evaluatePackageWith :: forall location term value inner inner' inner'' outer + -- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? + . ( Addressable location inner' , Evaluatable (Base term) , EvaluatableConstraints location term value inner , Member Fail outer , Member Fresh outer - , Member (Reader (Environment location)) outer , Member (Resumable (AddressError location value)) outer , Member (Resumable (LoadError location value)) outer , Member (State (Environment location)) outer @@ -93,7 +91,9 @@ evaluatePackageWith :: forall location term value inner outer , Member (State (ModuleTable (Maybe (Environment location, value)))) outer , Member Trace outer , Recursive term - , inner ~ (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': Reader Span ': Reader PackageInfo ': outer) + , inner ~ (LoopControl value ': Return value ': Env location ': Allocator location value ': inner') + , inner' ~ (Reader ModuleInfo ': inner'') + , inner'' ~ (Modules location value ': Reader Span ': Reader PackageInfo ': outer) ) => (SubtermAlgebra Module term (TermEvaluator term location value inner value) -> SubtermAlgebra Module term (TermEvaluator term location value inner value)) -> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value))) @@ -104,35 +104,38 @@ evaluatePackageWith analyzeModule analyzeTerm package . runReader lowerBound . runReader (packageModules (packageBody package)) . withPrelude (packagePrelude (packageBody package)) - . raiseHandler (runModules (runTermEvaluator . evalModule)) - $ traverse (uncurry evaluateEntryPoint) (ModuleTable.toPairs (packageEntryPoints (packageBody package))) + $ \ preludeEnv + -> raiseHandler (runModules (runTermEvaluator . evalModule preludeEnv)) + . traverse (uncurry (evaluateEntryPoint preludeEnv)) + $ ModuleTable.toPairs (packageEntryPoints (packageBody package)) where - evalModule m + evalModule preludeEnv m = pairValueWithEnv - . runInModule (moduleInfo m) + . runInModule preludeEnv (moduleInfo m) . analyzeModule (subtermRef . moduleBody) $ evalTerm <$> m evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term))) - runInModule info + runInModule preludeEnv info = runReader info . raiseHandler runAllocator + . raiseHandler (runEnv preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl - evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term location value (Modules location value ': Reader Span ': Reader PackageInfo ': outer) value - evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do + evaluateEntryPoint :: Environment location -> ModulePath -> Maybe Name -> TermEvaluator term location value inner'' value + evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do v <- maybe unit snd <$> require m maybe (pure v) ((`call` []) <=< variable) sym - evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do - _ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) - fst <$> evalModule prelude + evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do + _ <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) + fst <$> evalModule emptyEnv prelude - withPrelude Nothing a = a - withPrelude (Just prelude) a = do + withPrelude Nothing f = f emptyEnv + withPrelude (Just prelude) f = do preludeEnv <- evalPrelude prelude - raiseHandler (withDefaultEnvironment preludeEnv) a + f preludeEnv -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across From 23a2f7ee7b563491ac923d4be6785871d8fb56e7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 07:45:12 -0400 Subject: [PATCH 35/88] Fix a typo. --- src/Data/Syntax/Declaration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 67f0a3941..0b6dcce94 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -276,7 +276,7 @@ instance Evaluatable TypeAlias where v <- subtermValue typeAliasKind addr <- lookupOrAlloc name assign addr v - Rval v <$> bind name addr + Rval v <$ bind name addr instance Declarations a => Declarations (TypeAlias a) where declaredName TypeAlias{..} = declaredName typeAliasIdentifier From d9a0d4dad7f0d080b3a4c5d6c098084cf2b1c00c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 07:51:22 -0400 Subject: [PATCH 36/88] forLoop runs in Env. --- src/Control/Abstract/Value.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 0e36c279c..8f2ef910a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -159,7 +159,7 @@ asBool value = ifthenelse value (pure True) (pure False) -- | C-style for loops. forLoop :: ( AbstractValue location value effects - , Member (State (Environment location)) effects + , Member (Env location) effects ) => Evaluator location value effects value -- ^ Initial statement -> Evaluator location value effects value -- ^ Condition @@ -167,7 +167,7 @@ forLoop :: ( AbstractValue location value effects -> Evaluator location value effects value -- ^ Body -> Evaluator location value effects value forLoop initial cond step body = - localEnv id (initial *> while cond (body *> step)) + locally (initial *> while cond (body *> step)) -- | The fundamental looping primitive, built on top of 'ifthenelse'. while :: AbstractValue location value effects From d8aa3c9a41ebd62305403a49564525220ebc249f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 07:53:54 -0400 Subject: [PATCH 37/88] Use bindAll most places. --- src/Language/Go/Syntax.hs | 4 ++-- src/Language/PHP/Syntax.hs | 5 ++--- src/Language/Python/Syntax.hs | 9 ++++----- src/Language/Ruby/Syntax.hs | 4 ++-- src/Language/TypeScript/Syntax.hs | 10 +++++----- 5 files changed, 15 insertions(+), 17 deletions(-) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index c37a784f8..af200e6dc 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -70,7 +70,7 @@ instance Evaluatable Import where for_ paths $ \path -> do traceResolve (unPath importPath) path importedEnv <- maybe emptyEnv fst <$> isolate (require path) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv pure (Rval unit) @@ -94,7 +94,7 @@ instance Evaluatable QualifiedImport where for_ paths $ \p -> do traceResolve (unPath importPath) p importedEnv <- maybe emptyEnv fst <$> isolate (require p) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv makeNamespace alias addr Nothing pure (Rval unit) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 28094cc45..b11d1fc6a 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -54,11 +54,10 @@ resolvePHPName n = do include :: ( AbstractValue location value effects , Member (Allocator location value) effects + , Member (Env location) effects , Member (Modules location value) effects - , Member (Reader (Environment location)) effects , Member (Resumable ResolutionError) effects , Member (Resumable (EnvironmentError location)) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member Trace effects ) @@ -70,7 +69,7 @@ include pathTerm f = do path <- resolvePHPName name traceResolve name path (importedEnv, v) <- isolate (f path) >>= maybeM (pure (emptyEnv, unit)) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv pure (Rval v) newtype Require a = Require a diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 1aa99d740..7a275a258 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -117,7 +117,7 @@ instance Evaluatable Import where -- Last module path is the one we want to import let path = NonEmpty.last modulePaths importedEnv <- maybe emptyEnv fst <$> isolate (require path) - modifyEnv (mergeEnvs (select importedEnv)) + bindAll (select importedEnv) pure (Rval unit) where select importedEnv @@ -128,9 +128,8 @@ instance Evaluatable Import where -- Evaluate a qualified import evalQualifiedImport :: ( AbstractValue location value effects , Member (Allocator location value) effects + , Member (Env location) effects , Member (Modules location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location @@ -139,7 +138,7 @@ evalQualifiedImport :: ( AbstractValue location value effects => Name -> ModulePath -> Evaluator location value effects value evalQualifiedImport name path = letrec' name $ \addr -> do importedEnv <- maybe emptyEnv fst <$> isolate (require path) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv unit <$ makeNamespace name addr Nothing newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: QualifiedName } @@ -188,7 +187,7 @@ instance Evaluatable QualifiedAliasedImport where Rval <$> letrec' alias (\addr -> do let path = NonEmpty.last modulePaths importedEnv <- maybe emptyEnv fst <$> isolate (require path) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv unit <$ makeNamespace alias addr Nothing) -- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index ddc1db58d..f91f80e8f 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -109,9 +109,9 @@ instance Evaluatable Load where eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required") doLoad :: ( AbstractValue location value effects + , Member (Env location) effects , Member (Modules location value) effects , Member (Resumable ResolutionError) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member Trace effects ) @@ -122,7 +122,7 @@ doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' importedEnv <- maybe emptyEnv fst <$> isolate (load path') - unless shouldWrap $ modifyEnv (mergeEnvs importedEnv) + unless shouldWrap $ bindAll importedEnv pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load -- TODO: autoload diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index cac08b9c5..2659c28a6 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.TypeScript.Syntax where +import Data.Abstract.Address import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable import qualified Data.Abstract.Module as M @@ -134,9 +135,8 @@ javascriptExtensions = ["js"] evalRequire :: ( AbstractValue location value effects , Member (Allocator location value) effects + , Member (Env location) effects , Member (Modules location value) effects - , Member (Reader (Environment location)) effects - , Member (State (Environment location)) effects , Member (State (Exports location)) effects , Member (State (Heap location (Cell location) value)) effects , Ord location @@ -147,7 +147,7 @@ evalRequire :: ( AbstractValue location value effects -> Evaluator location value effects value evalRequire modulePath alias = letrec' alias $ \addr -> do importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) - modifyEnv (mergeEnvs importedEnv) + bindAll importedEnv unit <$ makeNamespace alias addr Nothing data Import a = Import { importSymbols :: ![(Name, Name)], importFrom :: ImportPath } @@ -164,7 +164,7 @@ instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) - modifyEnv (mergeEnvs (renamed importedEnv)) $> Rval unit + bindAll (renamed importedEnv) $> Rval unit where renamed importedEnv | Prologue.null symbols = importedEnv @@ -252,7 +252,7 @@ instance Evaluatable QualifiedExportFrom where -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv - maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address + maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just . Address) address pure (Rval unit) newtype DefaultExport a = DefaultExport { defaultExport :: a } From 5499528ac07817da1cafb7bb8906ea1b99d3dbe7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:24:25 -0400 Subject: [PATCH 38/88] Define a Ref datatype for references to values in the heap. --- src/Data/Abstract/Ref.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index c7412cde4..2b15de34a 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -12,3 +12,6 @@ data ValueRef value where -- | An object member. LvalMember :: value -> Name -> ValueRef value deriving (Eq, Ord, Show) + + +data Ref address value = Ref address From 8bcc9f4cb14ceef3ff26b4c0ea86d49ce547b4dd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:33:28 -0400 Subject: [PATCH 39/88] Placate hlint. --- src/Data/Abstract/Ref.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index 2b15de34a..4e218a598 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -14,4 +14,4 @@ data ValueRef value where deriving (Eq, Ord, Show) -data Ref address value = Ref address +newtype Ref address value = Ref address From 6adc5d7413db475f22816120bd677ed51a10df61 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:33:51 -0400 Subject: [PATCH 40/88] Placate hlint some more. --- test/SpecHelpers.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 49eec19db..6aee58368 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -34,7 +34,6 @@ import Data.Project as X import Data.Functor.Listable as X import Data.Language as X import Data.List.NonEmpty as X (NonEmpty(..)) -import Data.Monoid as X (Last(..)) import Data.Range as X import Data.Record as X import Data.Source as X From 9caf8893b69c10f0019bd6f5a91f4c3045fcd3dd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:36:16 -0400 Subject: [PATCH 41/88] Correct a couple of hints. --- HLint.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/HLint.hs b/HLint.hs index f488a4907..f0efa0933 100644 --- a/HLint.hs +++ b/HLint.hs @@ -17,8 +17,8 @@ error "Avoid return" = return ==> pure where note = "return is obsolete as of GHC 7.10" -error "use extract" = termAnnotation . unTerm ==> extract -error "use unwrap" = termOut . unTerm ==> unwrap +error "use termAnnotation" = termFAnnotation . unTerm ==> termAnnotation +error "use termOut" = termFOut . unTerm ==> termOut error "avoid head" = head where note = "head is partial; consider using Data.Maybe.listToMaybe" From 90ad5bc45ef850a33f0a2c5b49eac0d74ec24f81 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 10:37:16 -0400 Subject: [PATCH 42/88] Add a hint about maybeM. --- HLint.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/HLint.hs b/HLint.hs index f0efa0933..e02ff38b5 100644 --- a/HLint.hs +++ b/HLint.hs @@ -31,3 +31,5 @@ error "avoid init" = init error "avoid last" = last where note = "last is partial; consider pattern-matching" + +error "use maybeM" = maybe a pure ==> maybeM a From 12c6c39861c3a2e1523a0e09c4882833b4099d79 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 30 May 2018 09:48:16 -0500 Subject: [PATCH 43/88] cut State Environment over to Env effect --- src/Analysis/Abstract/Caching.hs | 4 ++-- src/Analysis/Abstract/Evaluating.hs | 4 ++-- src/Analysis/Abstract/Graph.hs | 4 ++-- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Configuration.hs | 2 +- src/Control/Abstract/Environment.hs | 16 ++++++++-------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 4 ++-- src/Semantic/Graph.hs | 2 +- 9 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index be0cc40c6..e1584ea0c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -62,7 +62,7 @@ cachingTerms :: ( Cacheable term address (Cell address) value , Member (Reader (Cache term address (Cell address) value)) effects , Member (Reader (Live address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value)) @@ -86,7 +86,7 @@ convergingModules :: ( AbstractValue address value effects , Member (Reader (Live address)) effects , Member (Resumable (EnvironmentError address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra Module term (TermEvaluator term address value effects value) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c126f5e1d..86a4670c6 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,7 +23,7 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show evaluating :: Evaluator address value ( Fail ': Fresh - ': State (Environment address) + ': Env address ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) ': State (Exports address) @@ -34,6 +34,6 @@ evaluating . runState lowerBound -- State (Exports address) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- State (Environment address) + . runState lowerBound -- Env address . runFresh 0 . runFail diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 970b7cef3..62765dd9c 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -54,7 +54,7 @@ style = (defaultStyle (byteString . vertexName)) graphingTerms :: ( Element Syntax.Identifier syntax , Member (Reader (Environment (Hole (Located address)))) effects , Member (Reader ModuleInfo) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects , term ~ Term (Sum syntax) ann ) @@ -122,7 +122,7 @@ moduleInclusion v = do -- | Add an edge from the passed variable name to the module it originated within. variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects ) => Name diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 80b35d067..ee6cc58b6 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Corecursive term , Member (Reader (Live address)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Member (Writer (trace (Configuration term address (Cell address) value))) effects , Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value)) diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 764168d8e..d89905f02 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator import Data.Abstract.Configuration -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Environment address)) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a01b56d1c..592750514 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -25,19 +25,19 @@ import Data.Abstract.Name import Prologue -- | Retrieve the environment. -getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address) +getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = get -- | Set the environment. -putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects () +putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () putEnv = put -- | Update the global environment. -modifyEnv :: Member (State (Environment address)) effects => (Environment address -> Environment address) -> Evaluator address value effects () +modifyEnv :: Member (Env address) effects => (Environment address -> Environment address) -> Evaluator address value effects () modifyEnv = modify' -- | Sets the environment for the lifetime of the given action. -withEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a +withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a withEnv = localState . const @@ -66,12 +66,12 @@ close = send . Close data Env address return where Lookup :: Name -> Env address (Maybe address) - Bind :: Name -> address -> Env address () + Bind :: Name -> address -> Env address () Close :: Set Name -> Env address (Environment address) Push :: Env address () Pop :: Env address () -handleEnv :: Member (State (Environment address)) effects => Environment address -> Env address result -> Evaluator address value effects result +handleEnv :: Member (Env address) effects => Environment address -> Env address result -> Evaluator address value effects result handleEnv defaultEnvironment = \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) @@ -79,10 +79,10 @@ handleEnv defaultEnvironment = \case Push -> modifyEnv Env.push Pop -> modifyEnv Env.pop -runEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects a +runEnv :: Member (Env address) effects => Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects a runEnv defaultEnvironment = interpret (handleEnv defaultEnvironment) -reinterpretEnv :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value (State (Environment address) ': effects) a +reinterpretEnv :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value (Env address ': effects) a reinterpretEnv defaultEnvironment = reinterpret (handleEnv defaultEnvironment) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 913a729f9..b4aa39867 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -187,7 +187,7 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue (pure unit) makeNamespace :: ( AbstractValue address value effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4d569512a..f591a79bb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -85,7 +85,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (State (Environment address)) outer + , Member (Env address) outer , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer @@ -147,7 +147,7 @@ evaluatePackageWith analyzeModule analyzeTerm package -- | Isolate the given action with an empty global environment and exports. -isolate :: (Member (State (Environment address)) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a +isolate :: (Member (Env address) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a isolate = withEnv lowerBound . withExports lowerBound traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 32f2c0be4..c5dbe114d 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member (Env address) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) From 8336c60f54298eee72f81abef94080cb7fe9fac2 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 30 May 2018 09:48:16 -0500 Subject: [PATCH 44/88] cut State Environment over to Env effect --- src/Analysis/Abstract/Caching.hs | 4 ++-- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/Graph.hs | 4 ++-- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Configuration.hs | 2 +- src/Control/Abstract/Environment.hs | 25 +++++++++++++++++-------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 2 +- src/Semantic/Graph.hs | 2 +- 9 files changed, 27 insertions(+), 18 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index be0cc40c6..e1584ea0c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -62,7 +62,7 @@ cachingTerms :: ( Cacheable term address (Cell address) value , Member (Reader (Cache term address (Cell address) value)) effects , Member (Reader (Live address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value)) @@ -86,7 +86,7 @@ convergingModules :: ( AbstractValue address value effects , Member (Reader (Live address)) effects , Member (Resumable (EnvironmentError address)) effects , Member (State (Cache term address (Cell address) value)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects ) => SubtermAlgebra Module term (TermEvaluator term address value effects value) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c126f5e1d..ab2cd383d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -34,6 +34,6 @@ evaluating . runState lowerBound -- State (Exports address) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- State (Environment address) + . runState lowerBound -- Env address . runFresh 0 . runFail diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 970b7cef3..62765dd9c 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -54,7 +54,7 @@ style = (defaultStyle (byteString . vertexName)) graphingTerms :: ( Element Syntax.Identifier syntax , Member (Reader (Environment (Hole (Located address)))) effects , Member (Reader ModuleInfo) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects , term ~ Term (Sum syntax) ann ) @@ -122,7 +122,7 @@ moduleInclusion v = do -- | Add an edge from the passed variable name to the module it originated within. variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects - , Member (State (Environment (Hole (Located address)))) effects + , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects ) => Name diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 80b35d067..ee6cc58b6 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Corecursive term , Member (Reader (Live address)) effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Member (Writer (trace (Configuration term address (Cell address) value))) effects , Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value)) diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 764168d8e..d89905f02 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator import Data.Abstract.Configuration -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Environment address)) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a01b56d1c..8e6f2fd91 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -25,19 +25,19 @@ import Data.Abstract.Name import Prologue -- | Retrieve the environment. -getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address) +getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = get -- | Set the environment. -putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects () +putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () putEnv = put -- | Update the global environment. -modifyEnv :: Member (State (Environment address)) effects => (Environment address -> Environment address) -> Evaluator address value effects () +modifyEnv :: Member (Env address) effects => (Environment address -> Environment address) -> Evaluator address value effects () modifyEnv = modify' -- | Sets the environment for the lifetime of the given action. -withEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a +withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a withEnv = localState . const @@ -66,12 +66,16 @@ close = send . Close data Env address return where Lookup :: Name -> Env address (Maybe address) - Bind :: Name -> address -> Env address () + Bind :: Name -> address -> Env address () Close :: Set Name -> Env address (Environment address) Push :: Env address () Pop :: Env address () -handleEnv :: Member (State (Environment address)) effects => Environment address -> Env address result -> Evaluator address value effects result +handleEnv :: forall address effects value result + . Member (State (Environment address)) effects + => Environment address + -> Env address result + -> Evaluator address value effects result handleEnv defaultEnvironment = \case Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv Bind name addr -> modifyEnv (Env.insert name addr) @@ -79,10 +83,15 @@ handleEnv defaultEnvironment = \case Push -> modifyEnv Env.push Pop -> modifyEnv Env.pop -runEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects a +runEnv :: Member (State (Environment address)) effects + => Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value effects a runEnv defaultEnvironment = interpret (handleEnv defaultEnvironment) -reinterpretEnv :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value (State (Environment address) ': effects) a +reinterpretEnv :: Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value (State (Environment address) ': effects) a reinterpretEnv defaultEnvironment = reinterpret (handleEnv defaultEnvironment) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 913a729f9..b4aa39867 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -187,7 +187,7 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue (pure unit) makeNamespace :: ( AbstractValue address value effects - , Member (State (Environment address)) effects + , Member (Env address) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 4d569512a..641895e6a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -147,7 +147,7 @@ evaluatePackageWith analyzeModule analyzeTerm package -- | Isolate the given action with an empty global environment and exports. -isolate :: (Member (State (Environment address)) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a +isolate :: (Member (Env address) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a isolate = withEnv lowerBound . withExports lowerBound traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 32f2c0be4..c5dbe114d 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member (Env address) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) From 820eac34804ca24a2a3d51e6c1a25152f8f28e32 Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 30 May 2018 10:20:06 -0500 Subject: [PATCH 45/88] rename location type var to address --- src/Data/Abstract/Type.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 77c4569f5..e112ce257 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -121,7 +121,7 @@ instance ( Member (Allocator address Type) effects , Member Fresh effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Heap location (Cell address) Type)) effects + , Member (State (Heap address (Cell address) Type)) effects , Ord address , Reducer Type (Cell address Type) ) @@ -151,7 +151,7 @@ instance ( Member (Allocator address Type) effects , Member NonDet effects , Member (Resumable TypeError) effects , Member (Return Type) effects - , Member (State (Heap location (Cell address) Type)) effects + , Member (State (Heap address (Cell address) Type)) effects , Ord address , Reducer Type (Cell address Type) ) From d13a5da554b5e483e12f4d130def3b54440f32bf Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Wed, 30 May 2018 11:38:35 -0500 Subject: [PATCH 46/88] WIP :pear: --- src/Control/Abstract/Environment.hs | 40 ++++++++++++++++------------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 8e6f2fd91..a0a821871 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -26,19 +26,20 @@ import Prologue -- | Retrieve the environment. getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) -getEnv = get +getEnv = send GetEnv -- | Set the environment. putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () -putEnv = put - --- | Update the global environment. -modifyEnv :: Member (Env address) effects => (Environment address -> Environment address) -> Evaluator address value effects () -modifyEnv = modify' +putEnv = send . PutEnv -- | Sets the environment for the lifetime of the given action. withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a -withEnv = localState . const +withEnv env m = do + oldEnv <- getEnv + putEnv env + result <- m + putEnv oldEnv + pure result -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. @@ -63,13 +64,14 @@ locally a = do close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address) close = send . Close - data Env address return where - Lookup :: Name -> Env address (Maybe address) - Bind :: Name -> address -> Env address () - Close :: Set Name -> Env address (Environment address) - Push :: Env address () - Pop :: Env address () + Lookup :: Name -> Env address (Maybe address) + Bind :: Name -> address -> Env address () + Close :: Set Name -> Env address (Environment address) + Push :: Env address () + Pop :: Env address () + GetEnv :: Env address (Environment address) + PutEnv :: Environment address -> Env address () handleEnv :: forall address effects value result . Member (State (Environment address)) effects @@ -77,11 +79,13 @@ handleEnv :: forall address effects value result -> Env address result -> Evaluator address value effects result handleEnv defaultEnvironment = \case - Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv - Bind name addr -> modifyEnv (Env.insert name addr) - Close names -> Env.intersect names <$> getEnv - Push -> modifyEnv Env.push - Pop -> modifyEnv Env.pop + Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> get + Bind name addr -> modify (Env.insert name addr) + Close names -> Env.intersect names <$> get + Push -> modify (Env.push @address) + Pop -> modify (Env.pop @address) + GetEnv -> get + PutEnv e -> put e runEnv :: Member (State (Environment address)) effects => Environment address From 99b92d336f016ae215d93c6aa42c2c3d5c73af83 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:41:04 -0400 Subject: [PATCH 47/88] :fire: redundant constraint. --- src/Analysis/Abstract/Caching.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index e1584ea0c..05c3fd135 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -82,7 +82,6 @@ convergingModules :: ( AbstractValue address value effects , Member Fresh effects , Member NonDet effects , Member (Reader (Cache term address (Cell address) value)) effects - , Member (Reader (Environment address)) effects , Member (Reader (Live address)) effects , Member (Resumable (EnvironmentError address)) effects , Member (State (Cache term address (Cell address) value)) effects From 8fca2b5ab54f284d1edbbb92017dd67e1f1ca0ae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:50:51 -0400 Subject: [PATCH 48/88] pairValueWithEnv acts in State, not Env. --- src/Data/Abstract/Evaluatable.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index f591a79bb..bb7d52b03 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -85,7 +85,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (Env address) outer + , Member (State (Environment address)) outer , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer @@ -143,7 +143,7 @@ evaluatePackageWith analyzeModule analyzeTerm package filterEnv ports env | Exports.null ports = env | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env - pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv) + pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator (get @(Environment address))) -- | Isolate the given action with an empty global environment and exports. From 707c5819df5c7e16dc36f1e576bf5988b8a2273d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:51:16 -0400 Subject: [PATCH 49/88] :fire: redundant constraints. --- src/Analysis/Abstract/Graph.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 62765dd9c..84931de66 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -52,7 +52,6 @@ style = (defaultStyle (byteString . vertexName)) -- | Add vertices to the graph for evaluated identifiers. graphingTerms :: ( Element Syntax.Identifier syntax - , Member (Reader (Environment (Hole (Located address)))) effects , Member (Reader ModuleInfo) effects , Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects @@ -121,8 +120,7 @@ moduleInclusion v = do appendGraph (vertex (moduleVertex m) `connect` vertex v) -- | Add an edge from the passed variable name to the module it originated within. -variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects - , Member (Env (Hole (Located address))) effects +variableDefinition :: ( Member (Env (Hole (Located address))) effects , Member (State (Graph Vertex)) effects ) => Name From a243f2d8379ee23c59bb044fcd4df8d1fee67a6b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:52:30 -0400 Subject: [PATCH 50/88] Evaluating runs the env state. --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 86a4670c6..c126f5e1d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,7 +23,7 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show evaluating :: Evaluator address value ( Fail ': Fresh - ': Env address + ': State (Environment address) ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) ': State (Exports address) @@ -34,6 +34,6 @@ evaluating . runState lowerBound -- State (Exports address) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- Env address + . runState lowerBound -- State (Environment address) . runFresh 0 . runFail From a5072958b55a2bb2ca9c899c6104c9ff37ab7e7e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 12:53:57 -0400 Subject: [PATCH 51/88] Run resumingValueError in State instead of Env. --- src/Semantic/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c5dbe114d..bbcfaaf77 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (Env address) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) @@ -139,7 +139,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err NumericError{} -> pure hole Numeric2Error{} -> pure hole ComparisonError{} -> pure hole - NamespaceError{} -> getEnv + NamespaceError{} -> get @(Environment _) BitwiseError{} -> pure hole Bitwise2Error{} -> pure hole KeyValueError{} -> pure (hole, hole) From f9c7f2836d99124042d99d0e2f026038e2774787 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:03:50 -0400 Subject: [PATCH 52/88] runEnv in the evaluator spec. --- test/Control/Abstract/Evaluator/Spec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index ddfb4c016..afcb2bc1e 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -38,6 +38,7 @@ evaluate . runEnvironmentError . runAddressError . runAllocator + . runEnv lowerBound . runReturn . runLoopControl From 3c81b7024a310cfae39557169b66b665b482e521 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:30:30 -0400 Subject: [PATCH 53/88] Define a runEnvState handler. --- src/Control/Abstract/Environment.hs | 31 +++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a0a821871..06255097b 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -12,6 +12,7 @@ module Control.Abstract.Environment , Env(..) , runEnv , reinterpretEnv +, runEnvState , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -75,11 +76,10 @@ data Env address return where handleEnv :: forall address effects value result . Member (State (Environment address)) effects - => Environment address - -> Env address result + => Env address result -> Evaluator address value effects result -handleEnv defaultEnvironment = \case - Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> get +handleEnv = \case + Lookup name -> Env.lookup name <$> get Bind name addr -> modify (Env.insert name addr) Close names -> Env.intersect names <$> get Push -> modify (Env.push @address) @@ -88,15 +88,26 @@ handleEnv defaultEnvironment = \case PutEnv e -> put e runEnv :: Member (State (Environment address)) effects - => Environment address - -> Evaluator address value (Env address ': effects) a + => Evaluator address value (Env address ': effects) a -> Evaluator address value effects a -runEnv defaultEnvironment = interpret (handleEnv defaultEnvironment) +runEnv = interpret handleEnv -reinterpretEnv :: Environment address - -> Evaluator address value (Env address ': effects) a +reinterpretEnv :: Evaluator address value (Env address ': effects) a -> Evaluator address value (State (Environment address) ': effects) a -reinterpretEnv defaultEnvironment = reinterpret (handleEnv defaultEnvironment) +reinterpretEnv = reinterpret handleEnv + +runEnvState :: forall address value effects a + . Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value effects (a, Environment address) +runEnvState initial = relayState initial (\ s a -> pure (a, s)) $ \ s eff yield -> case eff of + Lookup name -> yield s (Env.lookup name s) + Bind name addr -> yield (Env.insert name addr s) () + Close names -> yield s (Env.intersect names s) + Push -> yield (Env.push @address s) () + Pop -> yield (Env.pop @address s) () + GetEnv -> yield s s + PutEnv e -> yield e () -- | Errors involving the environment. From d4e6d87756153d23a3d291b4fe7520df92235beb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:46:29 -0400 Subject: [PATCH 54/88] Run the environment state in evaluatePackageWith. --- src/Control/Abstract/Modules.hs | 19 ++++++++++--------- src/Data/Abstract/Evaluatable.hs | 16 +++++++++------- 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index fb22b61bd..2853de21f 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -23,6 +23,7 @@ import Data.Abstract.Environment import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable import Data.Language +import Data.Tuple (swap) import Prologue -- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load. @@ -47,11 +48,11 @@ require path = lookupModule path >>= maybeM (load path) -- -- Always loads/evaluates. load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value)) -load = send . Load +load path = fmap swap <$> send (Load path) data Modules address value return where - Load :: ModulePath -> Modules address value (Maybe (Environment address, value)) + Load :: ModulePath -> Modules address value (Maybe (value, Environment address)) Lookup :: ModulePath -> Modules address value (Maybe (Maybe (Environment address, value))) Resolve :: [FilePath] -> Modules address value (Maybe ModulePath) List :: FilePath -> Modules address value [ModulePath] @@ -64,7 +65,7 @@ runModules :: forall term address value effects a , Member (State (ModuleTable (Maybe (Environment address, value)))) effects , Member Trace effects ) - => (Module term -> Evaluator address value (Modules address value ': effects) (Environment address, value)) + => (Module term -> Evaluator address value (Modules address value ': effects) (value, Environment address)) -> Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a runModules evaluateModule = go @@ -92,19 +93,19 @@ runModules evaluateModule = go getModuleTable :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, value))) getModuleTable = get -cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (Environment address, value) -> Evaluator address value effects (Maybe (Environment address, value)) -cacheModule path result = modify' (ModuleTable.insert path result) $> result +cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (value, Environment address) -> Evaluator address value effects (Maybe (value, Environment address)) +cacheModule path result = modify' (ModuleTable.insert path (swap <$> result)) $> result askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term]) askModuleTable = ask -newtype Merging m address value = Merging { runMerging :: m (Maybe (Environment address, value)) } +newtype Merging m address value = Merging { runMerging :: m (Maybe (value, Environment address)) } instance Applicative m => Semigroup (Merging m address value) where Merging a <> Merging b = Merging (merge <$> a <*> b) where merge a b = mergeJusts <$> a <*> b <|> a <|> b - mergeJusts (env1, _) (env2, v) = (mergeEnvs env1 env2, v) + mergeJusts (_, env1) (v, env2) = (v, mergeEnvs env1 env2) instance Applicative m => Monoid (Merging m address value) where mappend = (<>) @@ -113,7 +114,7 @@ instance Applicative m => Monoid (Merging m address value) where -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. data LoadError address value resume where - ModuleNotFound :: ModulePath -> LoadError address value (Maybe (Environment address, value)) + ModuleNotFound :: ModulePath -> LoadError address value (Maybe (value, Environment address)) deriving instance Eq (LoadError address value resume) deriving instance Show (LoadError address value resume) @@ -122,7 +123,7 @@ instance Show1 (LoadError address value) where instance Eq1 (LoadError address value) where liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b -moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value)) +moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (value, Environment address)) moduleNotFound = throwResumable . ModuleNotFound resumeLoadError :: Member (Resumable (LoadError address value)) effects => Evaluator address value effects a -> (forall resume . LoadError address value resume -> Evaluator address value effects resume) -> Evaluator address value effects a diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index bb7d52b03..c74e2af57 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -85,7 +85,6 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (State (Environment address)) outer , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer @@ -98,7 +97,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer => (SubtermAlgebra Module term (TermEvaluator term address value inner value) -> SubtermAlgebra Module term (TermEvaluator term address value inner value)) -> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value))) -> Package term - -> TermEvaluator term address value outer [value] + -> TermEvaluator term address value outer [(value, Environment address)] evaluatePackageWith analyzeModule analyzeTerm package = runReader (packageInfo package) . runReader lowerBound @@ -119,22 +118,22 @@ evaluatePackageWith analyzeModule analyzeTerm package runInModule preludeEnv info = runReader info . raiseHandler runAllocator - . raiseHandler (runEnv preludeEnv) + . raiseHandler (runEnvState preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl - evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' value + evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address) evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do v <- maybe unit snd <$> require m maybe (pure v) ((`call` []) <=< variable) sym evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do _ <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) - fst <$> evalModule emptyEnv prelude + evalModule emptyEnv prelude withPrelude Nothing f = f emptyEnv withPrelude (Just prelude) f = do - preludeEnv <- evalPrelude prelude + (_, preludeEnv) <- evalPrelude prelude f preludeEnv -- TODO: If the set of exports is empty because no exports have been @@ -143,7 +142,10 @@ evaluatePackageWith analyzeModule analyzeTerm package filterEnv ports env | Exports.null ports = env | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env - pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator (get @(Environment address))) + pairValueWithEnv action = do + (a, env) <- action + filtered <- filterEnv <$> TermEvaluator getExports <*> pure env + pure (a, filtered) -- | Isolate the given action with an empty global environment and exports. From 152ba7f5491a8e4f26cc303f3c9243143a0bfdcb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:52:39 -0400 Subject: [PATCH 55/88] Placate hlint. --- src/Language/PHP/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 492e5159a..8b8e47c5c 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -48,7 +48,7 @@ resolvePHPName :: ( Member (Modules address value) effects -> Evaluator address value effects ModulePath resolvePHPName n = do modulePath <- resolve [name] - maybe (throwResumable $ NotFoundError name [name] Language.PHP) pure modulePath + maybeM (throwResumable $ NotFoundError name [name] Language.PHP) modulePath where name = toName n toName = BC.unpack . dropRelativePrefix . stripQuotes From 36dabb27e65477c0100003c24568052c105512e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:53:55 -0400 Subject: [PATCH 56/88] We can use fromMaybe now. --- src/Language/PHP/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 8b8e47c5c..71094fe68 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -68,7 +68,7 @@ include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name traceResolve name path - (importedEnv, v) <- isolate (f path) >>= maybeM (pure (emptyEnv, unit)) + (importedEnv, v) <- fromMaybe (emptyEnv, unit) <$> isolate (f path) bindAll importedEnv pure (Rval v) From 0e6db98fa5bbd8f64a9f35a1c2c0856676326210 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:58:10 -0400 Subject: [PATCH 57/88] =?UTF-8?q?We=20shouldn=E2=80=99t=20need=20to=20isol?= =?UTF-8?q?ate=20any=20more.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Language/Go/Syntax.hs | 6 +++--- src/Language/PHP/Syntax.hs | 3 +-- src/Language/Python/Syntax.hs | 13 ++++++------- src/Language/Ruby/Syntax.hs | 5 ++--- src/Language/TypeScript/Syntax.hs | 9 ++++----- 5 files changed, 16 insertions(+), 20 deletions(-) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index b7ca2ab16..c9ab540a5 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -69,7 +69,7 @@ instance Evaluatable Import where paths <- resolveGoImport importPath for_ paths $ \path -> do traceResolve (unPath importPath) path - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv pure (Rval unit) @@ -93,7 +93,7 @@ instance Evaluatable QualifiedImport where void $ letrec' alias $ \addr -> do for_ paths $ \p -> do traceResolve (unPath importPath) p - importedEnv <- maybe emptyEnv fst <$> isolate (require p) + importedEnv <- maybe emptyEnv fst <$> require p bindAll importedEnv makeNamespace alias addr Nothing pure (Rval unit) @@ -112,7 +112,7 @@ instance Evaluatable SideEffectImport where eval (SideEffectImport importPath _) = do paths <- resolveGoImport importPath traceResolve (unPath importPath) paths - for_ paths $ \path -> isolate (require path) + for_ paths require pure (Rval unit) -- A composite literal in Go diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 71094fe68..2dd1175fb 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -58,7 +58,6 @@ include :: ( AbstractValue address value effects , Member (Modules address value) effects , Member (Resumable ResolutionError) effects , Member (Resumable (EnvironmentError address)) effects - , Member (State (Exports address)) effects , Member Trace effects ) => Subterm term (Evaluator address value effects (ValueRef value)) @@ -68,7 +67,7 @@ include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name traceResolve name path - (importedEnv, v) <- fromMaybe (emptyEnv, unit) <$> isolate (f path) + (importedEnv, v) <- fromMaybe (emptyEnv, unit) <$> f path bindAll importedEnv pure (Rval v) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 91c1651ce..9caa04fd0 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -112,11 +112,11 @@ instance Evaluatable Import where modulePaths <- resolvePythonModules name -- Eval parent modules first - for_ (NonEmpty.init modulePaths) (isolate . require) + for_ (NonEmpty.init modulePaths) require -- Last module path is the one we want to import let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll (select importedEnv) pure (Rval unit) where @@ -130,14 +130,13 @@ evalQualifiedImport :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects , Member (Modules address value) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer.Reducer value (Cell address value) ) => Name -> ModulePath -> Evaluator address value effects value evalQualifiedImport name path = letrec' name $ \addr -> do - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv unit <$ makeNamespace name addr Nothing @@ -161,7 +160,7 @@ instance Evaluatable QualifiedImport where go ((name, path) :| []) = evalQualifiedImport name path -- Evaluate each parent module, just creating a namespace go ((name, path) :| xs) = letrec' name $ \addr -> do - void $ isolate (require path) + void $ require path void $ go (NonEmpty.fromList xs) makeNamespace name addr Nothing @@ -180,13 +179,13 @@ instance Evaluatable QualifiedAliasedImport where modulePaths <- resolvePythonModules name -- Evaluate each parent module - for_ (NonEmpty.init modulePaths) (isolate . require) + for_ (NonEmpty.init modulePaths) require -- Evaluate and import the last module, aliasing and updating the environment alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm) Rval <$> letrec' alias (\addr -> do let path = NonEmpty.last modulePaths - importedEnv <- maybe emptyEnv fst <$> isolate (require path) + importedEnv <- maybe emptyEnv fst <$> require path bindAll importedEnv unit <$ makeNamespace alias addr Nothing) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index aeb76ece3..ec39e7577 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -73,7 +73,7 @@ instance Evaluatable Require where name <- subtermValue x >>= asString path <- resolveRubyName name traceResolve name path - (importedEnv, v) <- isolate (doRequire path) + (importedEnv, v) <- doRequire path bindAll importedEnv pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require @@ -112,7 +112,6 @@ doLoad :: ( AbstractValue address value effects , Member (Env address) effects , Member (Modules address value) effects , Member (Resumable ResolutionError) effects - , Member (State (Exports address)) effects , Member Trace effects ) => ByteString @@ -121,7 +120,7 @@ doLoad :: ( AbstractValue address value effects doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' - importedEnv <- maybe emptyEnv fst <$> isolate (load path') + importedEnv <- maybe emptyEnv fst <$> load path' unless shouldWrap $ bindAll importedEnv pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 7082fa8a2..ffe8b85ac 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -136,7 +136,6 @@ evalRequire :: ( AbstractValue address value effects , Member (Allocator address value) effects , Member (Env address) effects , Member (Modules address value) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Ord address , Reducer value (Cell address value) @@ -145,7 +144,7 @@ evalRequire :: ( AbstractValue address value effects -> Name -> Evaluator address value effects value evalRequire modulePath alias = letrec' alias $ \addr -> do - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath bindAll importedEnv unit <$ makeNamespace alias addr Nothing @@ -162,7 +161,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath bindAll (renamed importedEnv) $> Rval unit where renamed importedEnv @@ -212,7 +211,7 @@ instance ToJSONFields1 SideEffectImport instance Evaluatable SideEffectImport where eval (SideEffectImport importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - void $ isolate (require modulePath) + void $ require modulePath pure (Rval unit) @@ -247,7 +246,7 @@ instance ToJSONFields1 QualifiedExportFrom instance Evaluatable QualifiedExportFrom where eval (QualifiedExportFrom importPath exportSymbols) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath) + importedEnv <- maybe emptyEnv fst <$> require modulePath -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv From 728829afb090180693d683ef09a6f8827c8f7230 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 13:58:37 -0400 Subject: [PATCH 58/88] :fire: isolate. --- src/Data/Abstract/Evaluatable.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index c74e2af57..2aee4c875 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -3,7 +3,6 @@ module Data.Abstract.Evaluatable ( module X , Evaluatable(..) , evaluatePackageWith -, isolate , traceResolve -- | Effects , EvalError(..) @@ -148,10 +147,6 @@ evaluatePackageWith analyzeModule analyzeTerm package pure (a, filtered) --- | Isolate the given action with an empty global environment and exports. -isolate :: (Member (Env address) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a -isolate = withEnv lowerBound . withExports lowerBound - traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) From c9360b2c61c924e903adaceed55add439b2bcbca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:00:29 -0400 Subject: [PATCH 59/88] Compose runState on to deal with the state. --- src/Control/Abstract/Environment.hs | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 06255097b..a62dedaf5 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -96,18 +96,10 @@ reinterpretEnv :: Evaluator address value (Env address ': effects) a -> Evaluator address value (State (Environment address) ': effects) a reinterpretEnv = reinterpret handleEnv -runEnvState :: forall address value effects a - . Environment address +runEnvState :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnvState initial = relayState initial (\ s a -> pure (a, s)) $ \ s eff yield -> case eff of - Lookup name -> yield s (Env.lookup name s) - Bind name addr -> yield (Env.insert name addr s) () - Close names -> yield s (Env.intersect names s) - Push -> yield (Env.push @address s) () - Pop -> yield (Env.pop @address s) () - GetEnv -> yield s s - PutEnv e -> yield e () +runEnvState initial = runState initial . reinterpretEnv -- | Errors involving the environment. From adfa93f6c98c018d850191fef80f3e141862aaea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:03:19 -0400 Subject: [PATCH 60/88] :fire: withEnv. --- src/Control/Abstract/Environment.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index a62dedaf5..845802051 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -3,7 +3,6 @@ module Control.Abstract.Environment ( Environment , getEnv , putEnv -, withEnv , lookupEnv , bind , bindAll @@ -33,15 +32,6 @@ getEnv = send GetEnv putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () putEnv = send . PutEnv --- | Sets the environment for the lifetime of the given action. -withEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a -withEnv env m = do - oldEnv <- getEnv - putEnv env - result <- m - putEnv oldEnv - pure result - -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address) From 10d94548955c91f8b2b93edc13aa453e4347c579 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:05:42 -0400 Subject: [PATCH 61/88] Converge locally w.r.t. the environment. --- src/Analysis/Abstract/Caching.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 05c3fd135..aaf19fe21 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -93,7 +93,7 @@ convergingModules :: ( AbstractValue address value effects convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> isolateCache $ do + cache <- converge lowerBound (\ prevCache -> isolateCache $ raiseHandler locally $ do TermEvaluator (putEnv (configurationEnvironment c)) TermEvaluator (putHeap (configurationHeap c)) -- We need to reset fresh generation so that this invocation converges. From 19d4ebefa49c68bfcd1664ada8ff1021ad4e49aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:08:57 -0400 Subject: [PATCH 62/88] :fire: putEnv. --- src/Analysis/Abstract/Caching.hs | 1 - src/Control/Abstract/Environment.hs | 7 ------- 2 files changed, 8 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index aaf19fe21..f9056858a 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -94,7 +94,6 @@ convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge lowerBound (\ prevCache -> isolateCache $ raiseHandler locally $ do - TermEvaluator (putEnv (configurationEnvironment c)) TermEvaluator (putHeap (configurationHeap c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 845802051..6da2bd8f9 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -2,7 +2,6 @@ module Control.Abstract.Environment ( Environment , getEnv -, putEnv , lookupEnv , bind , bindAll @@ -28,10 +27,6 @@ import Prologue getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = send GetEnv --- | Set the environment. -putEnv :: Member (Env address) effects => Environment address -> Evaluator address value effects () -putEnv = send . PutEnv - -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address) @@ -62,7 +57,6 @@ data Env address return where Push :: Env address () Pop :: Env address () GetEnv :: Env address (Environment address) - PutEnv :: Environment address -> Env address () handleEnv :: forall address effects value result . Member (State (Environment address)) effects @@ -75,7 +69,6 @@ handleEnv = \case Push -> modify (Env.push @address) Pop -> modify (Env.pop @address) GetEnv -> get - PutEnv e -> put e runEnv :: Member (State (Environment address)) effects => Evaluator address value (Env address ': effects) a From f9ea94b8dae76817b2d83699b15ed6d8fcdaa1b0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:09:07 -0400 Subject: [PATCH 63/88] Placate hlint. --- src/Control/Abstract/Heap.hs | 2 +- src/Language/Python/Syntax.hs | 2 +- src/Language/Ruby/Syntax.hs | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 152a9c9e4..6650abb55 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -66,7 +66,7 @@ lookupOrAlloc :: ( Member (Allocator address value) effects ) => Name -> Evaluator address value effects address -lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure +lookupOrAlloc name = lookupEnv name >>= maybeM (alloc name) letrec :: ( Member (Allocator address value) effects diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 9caa04fd0..9a1de3925 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -81,7 +81,7 @@ resolvePythonModules q = do , path <.> ".py" ] modulePath <- resolve searchPaths - maybe (throwResumable $ NotFoundError path searchPaths Language.Python) pure modulePath + maybeM (throwResumable $ NotFoundError path searchPaths Language.Python) modulePath -- | Import declarations (symbols are added directly to the calling environment). diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index ec39e7577..1eb89f5cd 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -26,7 +26,7 @@ resolveRubyName name = do let name' = cleanNameOrPath name let paths = [name' <.> "rb"] modulePath <- resolve paths - maybe (throwResumable $ NotFoundError name' paths Language.Ruby) pure modulePath + maybeM (throwResumable $ NotFoundError name' paths Language.Ruby) modulePath -- load "/root/src/file.rb" resolveRubyPath :: ( Member (Modules address value) effects @@ -37,7 +37,7 @@ resolveRubyPath :: ( Member (Modules address value) effects resolveRubyPath path = do let name' = cleanNameOrPath path modulePath <- resolve [name'] - maybe (throwResumable $ NotFoundError name' [name'] Language.Ruby) pure modulePath + maybeM (throwResumable $ NotFoundError name' [name'] Language.Ruby) modulePath cleanNameOrPath :: ByteString -> String cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes From 5d9b9657d762f0df8de5cbbef4ad4223702a9d5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:15:32 -0400 Subject: [PATCH 64/88] Dedent. --- src/Control/Abstract/Environment.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 6da2bd8f9..d13399306 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -51,12 +51,12 @@ close :: Member (Env address) effects => Set Name -> Evaluator address value eff close = send . Close data Env address return where - Lookup :: Name -> Env address (Maybe address) - Bind :: Name -> address -> Env address () - Close :: Set Name -> Env address (Environment address) - Push :: Env address () - Pop :: Env address () - GetEnv :: Env address (Environment address) + Lookup :: Name -> Env address (Maybe address) + Bind :: Name -> address -> Env address () + Close :: Set Name -> Env address (Environment address) + Push :: Env address () + Pop :: Env address () + GetEnv :: Env address (Environment address) handleEnv :: forall address effects value result . Member (State (Environment address)) effects From f4c33d4d8fd087e301dd762a554d391c6f450fcf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:19:39 -0400 Subject: [PATCH 65/88] =?UTF-8?q?Don=E2=80=99t=20export=20modifyExports.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Exports.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index 5ad8bc1f3..a296acd9a 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -2,7 +2,6 @@ module Control.Abstract.Exports ( Exports , getExports , putExports -, modifyExports , addExport , withExports ) where From 7d67ee390539b621419db81077391e0295d8a797 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:20:01 -0400 Subject: [PATCH 66/88] :fire: putExports. --- src/Control/Abstract/Exports.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index a296acd9a..847a2cd45 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -1,7 +1,6 @@ module Control.Abstract.Exports ( Exports , getExports -, putExports , addExport , withExports ) where @@ -14,10 +13,6 @@ import Data.Abstract.Name getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) getExports = get --- | Set the global export state. -putExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects () -putExports = put - -- | Update the global export state. modifyExports :: Member (State (Exports address)) effects => (Exports address -> Exports address) -> Evaluator address value effects () modifyExports = modify' From 3ae5cc171ade7392fb378607c21f017ae795a0fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:20:23 -0400 Subject: [PATCH 67/88] :fire: withExports. --- src/Control/Abstract/Exports.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index 847a2cd45..15059cfbc 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -2,7 +2,6 @@ module Control.Abstract.Exports ( Exports , getExports , addExport -, withExports ) where import Control.Abstract.Evaluator @@ -20,7 +19,3 @@ modifyExports = modify' -- | Add an export to the global export state. addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () addExport name alias = modifyExports . insert name alias - --- | Sets the global export state for the lifetime of the given action. -withExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects a -> Evaluator address value effects a -withExports = localState . const From eff98cfb03720a19eb5f1c2f4ab85f69ce69dbed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:21:13 -0400 Subject: [PATCH 68/88] :fire: modifyExports. --- src/Control/Abstract/Exports.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs index 15059cfbc..cec8701ad 100644 --- a/src/Control/Abstract/Exports.hs +++ b/src/Control/Abstract/Exports.hs @@ -12,10 +12,6 @@ import Data.Abstract.Name getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) getExports = get --- | Update the global export state. -modifyExports :: Member (State (Exports address)) effects => (Exports address -> Exports address) -> Evaluator address value effects () -modifyExports = modify' - -- | Add an export to the global export state. addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -addExport name alias = modifyExports . insert name alias +addExport name alias = modify' . insert name alias From 11a92c0cb6d1e5b14617cf3e090977dc057d4e30 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:27:32 -0400 Subject: [PATCH 69/88] Move getExports & addExport into Control.Abstract.Environment. --- semantic.cabal | 1 - src/Control/Abstract.hs | 1 - src/Control/Abstract/Environment.hs | 12 ++++++++++++ src/Control/Abstract/Exports.hs | 17 ----------------- src/Data/Abstract/Evaluatable.hs | 1 - 5 files changed, 12 insertions(+), 20 deletions(-) delete mode 100644 src/Control/Abstract/Exports.hs diff --git a/semantic.cabal b/semantic.cabal index 1aa7f9d1f..83c6a7d23 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -41,7 +41,6 @@ library , Control.Abstract.Context , Control.Abstract.Environment , Control.Abstract.Evaluator - , Control.Abstract.Exports , Control.Abstract.Heap , Control.Abstract.Hole , Control.Abstract.Matching diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs index d33e384ff..6c6ad0cc1 100644 --- a/src/Control/Abstract.hs +++ b/src/Control/Abstract.hs @@ -7,7 +7,6 @@ import Control.Abstract.Configuration as X import Control.Abstract.Context as X import Control.Abstract.Environment as X hiding (Lookup) import Control.Abstract.Evaluator as X -import Control.Abstract.Exports as X import Control.Abstract.Heap as X import Control.Abstract.Hole as X import Control.Abstract.Modules as X diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index d13399306..12171c8f4 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -1,7 +1,10 @@ {-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Environment ( Environment +, Exports , getEnv +, getExports +, addExport , lookupEnv , bind , bindAll @@ -19,6 +22,7 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Environment (Environment) +import Data.Abstract.Exports import qualified Data.Abstract.Environment as Env import Data.Abstract.Name import Prologue @@ -27,6 +31,14 @@ import Prologue getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = send GetEnv +-- | Get the global export state. +getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) +getExports = get + +-- | Add an export to the global export state. +addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () +addExport name alias = modify' . insert name alias + -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. lookupEnv :: Member (Env address) effects => Name -> Evaluator address value effects (Maybe address) diff --git a/src/Control/Abstract/Exports.hs b/src/Control/Abstract/Exports.hs deleted file mode 100644 index cec8701ad..000000000 --- a/src/Control/Abstract/Exports.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Control.Abstract.Exports -( Exports -, getExports -, addExport -) where - -import Control.Abstract.Evaluator -import Data.Abstract.Exports -import Data.Abstract.Name - --- | Get the global export state. -getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) -getExports = get - --- | Add an export to the global export state. -addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -addExport name alias = modify' . insert name alias diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 2aee4c875..99321e541 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -19,7 +19,6 @@ import Control.Abstract import Control.Abstract.Context as X import Control.Abstract.Environment as X hiding (runEnvironmentError, runEnvironmentErrorWith) import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catchLoopControl, runLoopControl, catchReturn, runReturn) -import Control.Abstract.Exports as X import Control.Abstract.Heap as X hiding (AddressError(..), runAddressError, runAddressErrorWith) import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve) import Control.Abstract.Value as X From 6a3f4ba6898e3c6ed8d2286fcc2b9f50d408b8ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 14:30:02 -0400 Subject: [PATCH 70/88] Rename addExport to export. --- src/Control/Abstract/Environment.hs | 6 +++--- src/Language/TypeScript/Syntax.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 12171c8f4..253834aa2 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -4,7 +4,7 @@ module Control.Abstract.Environment , Exports , getEnv , getExports -, addExport +, export , lookupEnv , bind , bindAll @@ -36,8 +36,8 @@ getExports :: Member (State (Exports address)) effects => Evaluator address valu getExports = get -- | Add an export to the global export state. -addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -addExport name alias = modify' . insert name alias +export :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () +export name alias = modify' . insert name alias -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index ffe8b85ac..9cd3fe0cc 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -229,7 +229,7 @@ instance Evaluatable QualifiedExport where eval (QualifiedExport exportSymbols) = do -- Insert the aliases with no addresses. for_ exportSymbols $ \(name, alias) -> - addExport name alias Nothing + export name alias Nothing pure (Rval unit) @@ -250,7 +250,7 @@ instance Evaluatable QualifiedExportFrom where -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv - maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address + maybe (throwEvalError $ ExportError modulePath name) (export name alias . Just) address pure (Rval unit) newtype DefaultExport a = DefaultExport { defaultExport :: a } @@ -269,7 +269,7 @@ instance Evaluatable DefaultExport where Just name -> do addr <- lookupOrAlloc name assign addr v - addExport name name Nothing + export name name Nothing bind name addr Nothing -> throwEvalError DefaultExportError pure (Rval unit) From 0f6ad38a4e3f8683de28a8842ae34d3e27206d3d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:11:24 -0400 Subject: [PATCH 71/88] Move export into Env. --- src/Control/Abstract/Environment.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 253834aa2..50d089db2 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -22,9 +22,10 @@ module Control.Abstract.Environment import Control.Abstract.Evaluator import Data.Abstract.Environment (Environment) -import Data.Abstract.Exports import qualified Data.Abstract.Environment as Env +import Data.Abstract.Exports as Exports import Data.Abstract.Name +import Data.Semilattice.Lower import Prologue -- | Retrieve the environment. @@ -69,9 +70,12 @@ data Env address return where Push :: Env address () Pop :: Env address () GetEnv :: Env address (Environment address) + Export :: Name -> Name -> Maybe address -> Env address () handleEnv :: forall address effects value result - . Member (State (Environment address)) effects + . ( Member (State (Environment address)) effects + , Member (State (Exports address)) effects + ) => Env address result -> Evaluator address value effects result handleEnv = \case @@ -81,20 +85,23 @@ handleEnv = \case Push -> modify (Env.push @address) Pop -> modify (Env.pop @address) GetEnv -> get + Export name alias addr -> modify (Exports.insert name alias addr) -runEnv :: Member (State (Environment address)) effects +runEnv :: ( Member (State (Environment address)) effects + , Member (State (Exports address)) effects + ) => Evaluator address value (Env address ': effects) a -> Evaluator address value effects a runEnv = interpret handleEnv reinterpretEnv :: Evaluator address value (Env address ': effects) a - -> Evaluator address value (State (Environment address) ': effects) a -reinterpretEnv = reinterpret handleEnv + -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a +reinterpretEnv = reinterpret2 handleEnv runEnvState :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnvState initial = runState initial . reinterpretEnv +runEnvState initial = fmap fst . runState lowerBound . runState initial . reinterpretEnv -- | Errors involving the environment. From cb961fa994cef243d645f73f9ee83816be19d36d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:14:02 -0400 Subject: [PATCH 72/88] Handle exports in Env. --- src/Control/Abstract/Environment.hs | 8 +++++++- src/Data/Abstract/Evaluatable.hs | 16 +--------------- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 50d089db2..f13cab6bd 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -101,7 +101,13 @@ reinterpretEnv = reinterpret2 handleEnv runEnvState :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnvState initial = fmap fst . runState lowerBound . runState initial . reinterpretEnv +runEnvState initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpretEnv + where -- TODO: If the set of exports is empty because no exports have been + -- defined, do we export all terms, or no terms? This behavior varies across + -- languages. We need better semantics rather than doing it ad-hoc. + filterEnv (a, env) ports + | Exports.null ports = (a, env) + | otherwise = (a, Exports.toEnvironment ports `Env.mergeEnvs` Env.overwrite (Exports.aliases ports) env) -- | Errors involving the environment. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 99321e541..238b57ebe 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -24,7 +24,6 @@ import Control.Abstract.Modules as X (Modules, ResolutionError(..), load, lookup import Control.Abstract.Value as X import Data.Abstract.Declarations as X import Data.Abstract.Environment as X -import Data.Abstract.Exports as Exports import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable @@ -83,7 +82,6 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer , Member Fresh outer , Member (Resumable (AddressError address value)) outer , Member (Resumable (LoadError address value)) outer - , Member (State (Exports address)) outer , Member (State (Heap address (Cell address) value)) outer , Member (State (ModuleTable (Maybe (Environment address, value)))) outer , Member Trace outer @@ -107,8 +105,7 @@ evaluatePackageWith analyzeModule analyzeTerm package $ ModuleTable.toPairs (packageEntryPoints (packageBody package)) where evalModule preludeEnv m - = pairValueWithEnv - . runInModule preludeEnv (moduleInfo m) + = runInModule preludeEnv (moduleInfo m) . analyzeModule (subtermRef . moduleBody) $ evalTerm <$> m evalTerm term = Subterm term (TermEvaluator (value =<< runTermEvaluator (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term))) @@ -134,17 +131,6 @@ evaluatePackageWith analyzeModule analyzeTerm package (_, preludeEnv) <- evalPrelude prelude f preludeEnv - -- TODO: If the set of exports is empty because no exports have been - -- defined, do we export all terms, or no terms? This behavior varies across - -- languages. We need better semantics rather than doing it ad-hoc. - filterEnv ports env - | Exports.null ports = env - | otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env - pairValueWithEnv action = do - (a, env) <- action - filtered <- filterEnv <$> TermEvaluator getExports <*> pure env - pure (a, filtered) - traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects () traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) From da79d76872e31c7d5e9dd3d68b36ec2eb1eaff67 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:14:17 -0400 Subject: [PATCH 73/88] :fire: getExports. --- src/Control/Abstract/Environment.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index f13cab6bd..98cb652f1 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -3,7 +3,6 @@ module Control.Abstract.Environment ( Environment , Exports , getEnv -, getExports , export , lookupEnv , bind @@ -32,10 +31,6 @@ import Prologue getEnv :: Member (Env address) effects => Evaluator address value effects (Environment address) getEnv = send GetEnv --- | Get the global export state. -getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address) -getExports = get - -- | Add an export to the global export state. export :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () export name alias = modify' . insert name alias From 293d76a32fbc9cf90fab0a68b9995165d7c5b210 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:17:02 -0400 Subject: [PATCH 74/88] export sends Export. --- src/Control/Abstract/Environment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 98cb652f1..8f1a9c515 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -32,8 +32,8 @@ getEnv :: Member (Env address) effects => Evaluator address value effects (Envir getEnv = send GetEnv -- | Add an export to the global export state. -export :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects () -export name alias = modify' . insert name alias +export :: Member (Env address) effects => Name -> Name -> Maybe address -> Evaluator address value effects () +export name alias addr = send (Export name alias addr) -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. From 5bef9603e9342b3b2b9bd3a283bfa11157486e07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:17:23 -0400 Subject: [PATCH 75/88] :fire: the export effect in Evaluatable instances. --- src/Data/Abstract/Evaluatable.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 238b57ebe..6e55cd876 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -64,7 +64,6 @@ type EvaluatableConstraints address term value effects = , Member (Resumable ResolutionError) effects , Member (Resumable (Unspecialized value)) effects , Member (Return value) effects - , Member (State (Exports address)) effects , Member (State (Heap address (Cell address) value)) effects , Member Trace effects , Ord address From d01ef4e0b73f97cb8bcf12600c1885cbf54caeb1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:17:35 -0400 Subject: [PATCH 76/88] :fire: the exports in the evaluating state. --- src/Analysis/Abstract/Evaluating.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c126f5e1d..7af44030c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -12,7 +12,6 @@ data EvaluatingState address value = EvaluatingState { environment :: Environment address , heap :: Heap address (Cell address) value , modules :: ModuleTable (Maybe (Environment address, value)) - , exports :: Exports address } deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value) @@ -26,12 +25,10 @@ evaluating :: Evaluator address value ': State (Environment address) ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) - ': State (Exports address) ': effects) result -> Evaluator address value effects (Either String result, EvaluatingState address value) evaluating - = fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports)) - . runState lowerBound -- State (Exports address) + = fmap (\ (((result, env), heap), modules) -> (result, EvaluatingState env heap modules)) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) . runState lowerBound -- State (Environment address) From 7072b1f8ddf97c8ed9a69ee310b3f570914e404b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:19:50 -0400 Subject: [PATCH 77/88] =?UTF-8?q?Don=E2=80=99t=20re-export=20Fail.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Evaluating.hs | 1 + src/Control/Abstract/TermEvaluator.hs | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 7af44030c..53abb3c52 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -5,6 +5,7 @@ module Analysis.Abstract.Evaluating ) where import Control.Abstract +import Control.Monad.Effect.Fail import Data.Semilattice.Lower -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. diff --git a/src/Control/Abstract/TermEvaluator.hs b/src/Control/Abstract/TermEvaluator.hs index 40912ad44..553261078 100644 --- a/src/Control/Abstract/TermEvaluator.hs +++ b/src/Control/Abstract/TermEvaluator.hs @@ -7,7 +7,6 @@ module Control.Abstract.TermEvaluator import Control.Abstract.Evaluator import Control.Monad.Effect as X -import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Fresh as X import Control.Monad.Effect.NonDet as X import Control.Monad.Effect.Reader as X From 66594cf6314b639ee962372ab7ee8ae4fac71973 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:32:29 -0400 Subject: [PATCH 78/88] =?UTF-8?q?Don=E2=80=99t=20expect=20an=20env=20in=20?= =?UTF-8?q?resumingValueError.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Semantic/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index bbcfaaf77..a4b8f07a7 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -129,7 +129,7 @@ resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> s UnallocatedAddress _ -> pure lowerBound UninitializedAddress _ -> pure hole) -resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of CallError val -> pure val StringError val -> pure (pack (show val)) @@ -139,7 +139,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err NumericError{} -> pure hole Numeric2Error{} -> pure hole ComparisonError{} -> pure hole - NamespaceError{} -> get @(Environment _) + NamespaceError{} -> pure emptyEnv BitwiseError{} -> pure hole Bitwise2Error{} -> pure hole KeyValueError{} -> pure (hole, hole) From a6025262c5bfa0510d7c5fced6bcca3576377be3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:32:54 -0400 Subject: [PATCH 79/88] :fire: the environment from EvaluatingState. --- src/Analysis/Abstract/Evaluating.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 53abb3c52..b6307cf0c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -10,8 +10,7 @@ import Data.Semilattice.Lower -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. data EvaluatingState address value = EvaluatingState - { environment :: Environment address - , heap :: Heap address (Cell address) value + { heap :: Heap address (Cell address) value , modules :: ModuleTable (Maybe (Environment address, value)) } @@ -23,15 +22,13 @@ deriving instance (Show (Cell address value), Show address, Show value) => Show evaluating :: Evaluator address value ( Fail ': Fresh - ': State (Environment address) ': State (Heap address (Cell address) value) ': State (ModuleTable (Maybe (Environment address, value))) ': effects) result -> Evaluator address value effects (Either String result, EvaluatingState address value) evaluating - = fmap (\ (((result, env), heap), modules) -> (result, EvaluatingState env heap modules)) + = fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules)) . runState lowerBound -- State (ModuleTable (Maybe (Environment address, value))) . runState lowerBound -- State (Heap address (Cell address) value) - . runState lowerBound -- State (Environment address) . runFresh 0 . runFail From bf35d9db79e4dc6882d3f15437404481959b46bc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 15:33:56 -0400 Subject: [PATCH 80/88] We only need one handler. --- src/Control/Abstract/Environment.hs | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 8f1a9c515..8cd7dc206 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -10,8 +10,6 @@ module Control.Abstract.Environment , locally , close , Env(..) -, runEnv -, reinterpretEnv , runEnvState , EnvironmentError(..) , freeVariableError @@ -82,21 +80,10 @@ handleEnv = \case GetEnv -> get Export name alias addr -> modify (Exports.insert name alias addr) -runEnv :: ( Member (State (Environment address)) effects - , Member (State (Exports address)) effects - ) - => Evaluator address value (Env address ': effects) a - -> Evaluator address value effects a -runEnv = interpret handleEnv - -reinterpretEnv :: Evaluator address value (Env address ': effects) a - -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a -reinterpretEnv = reinterpret2 handleEnv - runEnvState :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnvState initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpretEnv +runEnvState initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. From deaaa80a521d4b4f07a2e748cf666b4caad1c10b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 17:17:01 -0400 Subject: [PATCH 81/88] Rename runEnvState to runEnv. --- src/Control/Abstract/Environment.hs | 10 +++++----- src/Data/Abstract/Evaluatable.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 8cd7dc206..551d6054a 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -10,7 +10,7 @@ module Control.Abstract.Environment , locally , close , Env(..) -, runEnvState +, runEnv , EnvironmentError(..) , freeVariableError , runEnvironmentError @@ -80,10 +80,10 @@ handleEnv = \case GetEnv -> get Export name alias addr -> modify (Exports.insert name alias addr) -runEnvState :: Environment address - -> Evaluator address value (Env address ': effects) a - -> Evaluator address value effects (a, Environment address) -runEnvState initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpret2 handleEnv +runEnv :: Environment address + -> Evaluator address value (Env address ': effects) a + -> Evaluator address value effects (a, Environment address) +runEnv initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 6e55cd876..3cfbb174e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -112,7 +112,7 @@ evaluatePackageWith analyzeModule analyzeTerm package runInModule preludeEnv info = runReader info . raiseHandler runAllocator - . raiseHandler (runEnvState preludeEnv) + . raiseHandler (runEnv preludeEnv) . raiseHandler runReturn . raiseHandler runLoopControl From bcf9338b751f46af8cdfd548bfed45d55532edf0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 17:19:05 -0400 Subject: [PATCH 82/88] Update the language specs to respect the env-per-entry-point thing. --- test/Analysis/Go/Spec.hs | 12 +++++------ test/Analysis/PHP/Spec.hs | 22 +++++++++---------- test/Analysis/Python/Spec.hs | 24 ++++++++++----------- test/Analysis/Ruby/Spec.hs | 37 ++++++++++++++++---------------- test/Analysis/TypeScript/Spec.hs | 16 +++++++------- 5 files changed, 55 insertions(+), 56 deletions(-) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index b0b43cd97..7c4cfd105 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -11,16 +11,16 @@ spec :: Spec spec = parallel $ do describe "evaluates Go" $ do it "imports and wildcard imports" $ do - ((_, state), _) <- evaluate "main.go" - Env.names (environment state) `shouldBe` [ "Bar", "Rab", "foo", "main" ] + ((Right [(_, env)], state), _) <- evaluate "main.go" + Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ] - (derefQName (heap state) ("foo" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("foo", ["New"]) + (derefQName (heap state) ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"]) it "imports with aliases (and side effects only)" $ do - ((_, state), _) <- evaluate "main1.go" - Env.names (environment state) `shouldBe` [ "f", "main" ] + ((Right [(_, env)], state), _) <- evaluate "main1.go" + Env.names env `shouldBe` [ "f", "main" ] - (derefQName (heap state) ("f" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("f", ["New"]) + (derefQName (heap state) ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"]) where fixtures = "test/fixtures/go/analysis/" diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 619136202..168139d48 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -12,22 +12,22 @@ spec :: Spec spec = parallel $ do describe "PHP" $ do it "evaluates include and require" $ do - ((res, state), _) <- evaluate "main.php" - res `shouldBe` Right [unit] - Env.names (environment state) `shouldBe` [ "bar", "foo" ] + ((Right [(res, env)], state), _) <- evaluate "main.php" + res `shouldBe` unit + Env.names env `shouldBe` [ "bar", "foo" ] it "evaluates include_once and require_once" $ do - ((res, state), _) <- evaluate "main_once.php" - res `shouldBe` Right [unit] - Env.names (environment state) `shouldBe` [ "bar", "foo" ] + ((Right [(res, env)], state), _) <- evaluate "main_once.php" + res `shouldBe` unit + Env.names env `shouldBe` [ "bar", "foo" ] it "evaluates namespaces" $ do - ((_, state), _) <- evaluate "namespaces.php" - Env.names (environment state) `shouldBe` [ "Foo", "NS1" ] + ((Right [(_, env)], state), _) <- evaluate "namespaces.php" + Env.names env `shouldBe` [ "Foo", "NS1" ] - (derefQName (heap state) ("NS1" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) - (derefQName (heap state) ("NS1" :| ["Sub1"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) - (derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) + (derefQName (heap state) ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) + (derefQName (heap state) ("NS1" :| ["Sub1"]) env >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"]) + (derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace) `shouldBe` Just ("Sub2", ["f"]) where fixtures = "test/fixtures/php/analysis/" diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 9bd89b98c..66ad0df48 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -14,33 +14,33 @@ spec :: Spec spec = parallel $ do describe "evaluates Python" $ do it "imports" $ do - ((_, state), _) <- evaluate "main.py" - Env.names (environment state) `shouldContain` [ "a", "b" ] + ((Right [(_, env)], state), _) <- evaluate "main.py" + Env.names env `shouldContain` [ "a", "b" ] - (derefQName (heap state) ("a" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("a", ["foo"]) - (derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", ["c"]) - (derefQName (heap state) ("b" :| ["c"]) (environment state) >>= deNamespace) `shouldBe` Just ("c", ["baz"]) + (derefQName (heap state) ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"]) + (derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", ["c"]) + (derefQName (heap state) ("b" :| ["c"]) env >>= deNamespace) `shouldBe` Just ("c", ["baz"]) it "imports with aliases" $ do - env <- environment . snd . fst <$> evaluate "main1.py" + ((Right [(_, env)], _), _) <- evaluate "main1.py" Env.names env `shouldContain` [ "b", "e" ] it "imports using 'from' syntax" $ do - env <- environment . snd . fst <$> evaluate "main2.py" + ((Right [(_, env)], _), _) <- evaluate "main2.py" Env.names env `shouldContain` [ "bar", "foo" ] it "imports with relative syntax" $ do - ((_, state), _) <- evaluate "main3.py" - Env.names (environment state) `shouldContain` [ "utils" ] - (derefQName (heap state) ("utils" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) + ((Right [(_, env)], state), _) <- evaluate "main3.py" + Env.names env `shouldContain` [ "utils" ] + (derefQName (heap state) ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"]) it "subclasses" $ do ((res, _), _) <- evaluate "subclass.py" - res `shouldBe` Right [String "\"bar\""] + fmap fst <$> res `shouldBe` Right [String "\"bar\""] it "handles multiple inheritance left-to-right" $ do ((res, _), _) <- evaluate "multiple_inheritance.py" - res `shouldBe` Right [String "\"foo!\""] + fmap fst <$> res `shouldBe` Right [String "\"foo!\""] where ns n = Just . Latest . Last . Just . Namespace n diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 5b9743906..83958cde8 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -20,58 +20,57 @@ spec :: Spec spec = parallel $ do describe "Ruby" $ do it "evaluates require_relative" $ do - ((res, state), _) <- evaluate "main.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 1)] - Env.names (environment state) `shouldContain` ["foo"] + ((Right [(res, env)], state), _) <- evaluate "main.rb" + res `shouldBe` Value.Integer (Number.Integer 1) + Env.names env `shouldContain` ["foo"] it "evaluates load" $ do - env <- environment . snd . fst <$> evaluate "load.rb" + ((Right [(_, env)], _), _) <- evaluate "load.rb" Env.names env `shouldContain` ["foo"] it "evaluates load with wrapper" $ do ((res, state), _) <- evaluate "load-wrap.rb" res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo"))) - Env.names (environment state) `shouldContain` [ "Object" ] it "evaluates subclass" $ do - ((res, state), _) <- evaluate "subclass.rb" - res `shouldBe` Right [String "\"\""] - Env.names (environment state) `shouldContain` [ "Bar", "Foo" ] + ((Right [(res, env)], state), _) <- evaluate "subclass.rb" + res `shouldBe` String "\"\"" + Env.names env `shouldContain` [ "Bar", "Foo" ] - (derefQName (heap state) ("Bar" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) + (derefQName (heap state) ("Bar" :| []) env >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) it "evaluates modules" $ do - ((res, state), _) <- evaluate "modules.rb" - res `shouldBe` Right [String "\"\""] - Env.names (environment state) `shouldContain` [ "Bar" ] + ((Right [(res, env)], state), _) <- evaluate "modules.rb" + res `shouldBe` String "\"\"" + Env.names env `shouldContain` [ "Bar" ] it "handles break correctly" $ do ((res, _), _) <- evaluate "break.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 3)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 3)] it "handles break correctly" $ do ((res, _), _) <- evaluate "next.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 8)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 8)] it "calls functions with arguments" $ do ((res, _), _) <- evaluate "call.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 579)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 579)] it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 123)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 123)] it "has prelude" $ do ((res, _), _) <- evaluate "preluded.rb" - res `shouldBe` Right [String "\"\""] + fmap fst <$> res `shouldBe` Right [String "\"\""] it "evaluates __LINE__" $ do ((res, _), _) <- evaluate "line.rb" - res `shouldBe` Right [Value.Integer (Number.Integer 4)] + fmap fst <$> res `shouldBe` Right [Value.Integer (Number.Integer 4)] it "resolves builtins used in the prelude" $ do ((res, _), traces) <- evaluate "puts.rb" - res `shouldBe` Right [Unit] + fmap fst <$> res `shouldBe` Right [Unit] traces `shouldContain` [ "\"hello\"" ] where diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index bb5a29b5b..acb871251 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -15,19 +15,19 @@ spec :: Spec spec = parallel $ do describe "evaluates TypeScript" $ do it "imports with aliased symbols" $ do - env <- environment . snd . fst <$> evaluate "main.ts" + ((Right [(_, env)], _), _) <- evaluate "main.ts" Env.names env `shouldBe` [ "bar", "quz" ] it "imports with qualified names" $ do - ((_, state), _) <- evaluate "main1.ts" - Env.names (environment state) `shouldBe` [ "b", "z" ] + ((Right [(_, env)], state), _) <- evaluate "main1.ts" + Env.names env `shouldBe` [ "b", "z" ] - (derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) - (derefQName (heap state) ("z" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) + (derefQName (heap state) ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ]) + (derefQName (heap state) ("z" :| []) env >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ]) it "side effect only imports" $ do - env <- environment . snd . fst <$> evaluate "main2.ts" - env `shouldBe` emptyEnv + ((res, _), _) <- evaluate "main2.ts" + fmap snd <$> res `shouldBe` Right [emptyEnv] it "fails exporting symbols not defined in the module" $ do ((res, _), _) <- evaluate "bad-export.ts" @@ -35,7 +35,7 @@ spec = parallel $ do it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.ts" - res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] + fmap fst <$> res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] where fixtures = "test/fixtures/typescript/analysis/" From 08cf65718f03cbb01dfd30ae11fb2225b770b5e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 17:20:08 -0400 Subject: [PATCH 83/88] Fix the evaluator spec. --- test/Control/Abstract/Evaluator/Spec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index afcb2bc1e..28100f6b1 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -20,13 +20,13 @@ spec :: Spec spec = parallel $ do it "constructs integers" $ do (expected, _) <- evaluate (pure (integer 123)) - expected `shouldBe` Right (Value.Integer (Number.Integer 123)) + fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123)) it "calls functions" $ do (expected, _) <- evaluate $ do identity <- closure [name "x"] lowerBound (variable (name "x")) call identity [pure (integer 123)] - expected `shouldBe` Right (Value.Integer (Number.Integer 123)) + fst <$> expected `shouldBe` Right (Value.Integer (Number.Integer 123)) evaluate = runM From 7e68c0723aba2df7b7e8bd0812447ca6e4eba564 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 17:40:53 -0400 Subject: [PATCH 84/88] Fix the Show instance for ClosureBody to not break prettyShow. --- src/Data/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 9adcae192..f81646456 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -42,7 +42,7 @@ instance Ord (ClosureBody address body) where compare = compare `on` closureBodyId instance Show (ClosureBody address body) where - showsPrec d (ClosureBody i _) = showsBinaryWith showsPrec (const showChar) "ClosureBody" d i '_' + showsPrec d (ClosureBody i _) = showsUnaryWith showsPrec "ClosureBody" d i instance Ord address => ValueRoots address (Value address body) where From 334f8738c02cdbeff7911ffc097bbbe72620aa80 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:13:36 -0400 Subject: [PATCH 85/88] Keep the builtins around. --- src/Data/Abstract/Evaluatable.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 3cfbb174e..31d761ebb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -122,8 +122,8 @@ evaluatePackageWith analyzeModule analyzeTerm package maybe (pure v) ((`call` []) <=< variable) sym evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do - _ <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) - evalModule emptyEnv prelude + (_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) + second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude withPrelude Nothing f = f emptyEnv withPrelude (Just prelude) f = do From d441d984561144505dffce035f8981beb35150e2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:29:30 -0400 Subject: [PATCH 86/88] Copy the environment back out for entry points. --- src/Data/Abstract/Evaluatable.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 31d761ebb..cadaf3cf1 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -118,8 +118,9 @@ evaluatePackageWith analyzeModule analyzeTerm package evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (value, Environment address) evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do - v <- maybe unit snd <$> require m - maybe (pure v) ((`call` []) <=< variable) sym + (env, value) <- fromMaybe (emptyEnv, unit) <$> require m + bindAll env + maybe (pure value) ((`call` []) <=< variable) sym evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do (_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit)) From 68e4c4615e4f9d505d53e53741eea7efde6fb03e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:35:38 -0400 Subject: [PATCH 87/88] Push the prelude env & drop it before filtering. --- src/Control/Abstract/Environment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Environment.hs b/src/Control/Abstract/Environment.hs index 551d6054a..c91254b53 100644 --- a/src/Control/Abstract/Environment.hs +++ b/src/Control/Abstract/Environment.hs @@ -83,7 +83,7 @@ handleEnv = \case runEnv :: Environment address -> Evaluator address value (Env address ': effects) a -> Evaluator address value effects (a, Environment address) -runEnv initial = fmap (uncurry filterEnv) . runState lowerBound . runState initial . reinterpret2 handleEnv +runEnv initial = fmap (uncurry filterEnv . first (fmap Env.head)) . runState lowerBound . runState (Env.push initial) . reinterpret2 handleEnv where -- TODO: If the set of exports is empty because no exports have been -- defined, do we export all terms, or no terms? This behavior varies across -- languages. We need better semantics rather than doing it ad-hoc. From c7e8419e296e70b875f0da74b017fe5ffb8fb3c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 30 May 2018 18:56:50 -0400 Subject: [PATCH 88/88] Placate hlint. --- src/Diffing/Algorithm.hs | 2 +- src/Semantic/IO.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index b6b0b300a..be17fd252 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -221,7 +221,7 @@ instance Diffable [] where -- | Diff two non-empty lists using RWS. instance Diffable NonEmpty where - algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybe empty pure + algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybeM empty tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> tryAlignWith f as1 as2 diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 60e1dd162..9a594e557 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -96,7 +96,7 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle readBlobFromPath :: MonadIO m => File -> m Blob.Blob readBlobFromPath file = do maybeFile <- readFile file - maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile + maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project readProjectFromPaths maybeRoot path lang excludeDirs = do