From 4d85b1f18e27a0a69e2bd138042c0bd72ba2282f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 12:48:21 -0400 Subject: [PATCH 01/25] Define an evaluating state type. --- src/Analysis/Abstract/Evaluating.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b0ca91151..9116d4d32 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -43,6 +43,14 @@ type EvaluatingEffects term value , State (IntMap.IntMap term) -- For jumps ] +data EvaluatingState term value = EvaluatingState + { environment :: EnvironmentFor value + , heap :: HeapFor value + , modules :: ModuleTable (EnvironmentFor value, value) + , exports :: ExportsFor value + , jumps :: IntMap.IntMap term + } + -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) value)) From 60a1dcedddda09dd4f4a4ecb9a29ca61b7bb38ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 13:00:24 -0400 Subject: [PATCH 02/25] Rename unStore to unHeap. --- src/Data/Abstract/Heap.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 12a766a3f..5035d716b 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -8,7 +8,7 @@ import Data.Semigroup.Reducer import Prologue -- | A map of addresses onto cells holding their values. -newtype Heap l a = Heap { unStore :: Monoidal.Map l (Cell l a) } +newtype Heap l a = Heap { unHeap :: Monoidal.Map l (Cell l a) } deriving (Generic1) deriving instance (Eq l, Eq (Cell l a)) => Eq (Heap l a) @@ -26,7 +26,7 @@ deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Heap l a) -- | Look up the cell of values for an 'Address' in a 'Heap', if any. heapLookup :: Ord l => Address l a -> Heap l a -> Maybe (Cell l a) -heapLookup (Address address) = Monoidal.lookup address . unStore +heapLookup (Address address) = Monoidal.lookup address . unHeap -- | Look up the list of values stored for a given address, if any. heapLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Heap l a -> Maybe [a] @@ -42,7 +42,7 @@ heapInit (Address address) cell (Heap h) = Heap (Monoidal.insert address cell h) -- | The number of addresses extant in a 'Heap'. heapSize :: Heap l a -> Int -heapSize = Monoidal.size . unStore +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 l => Heap l a -> Live l a -> Heap l a From 58b6c5ab0437b2f0cda70ad0bc0946c46a9ec1af Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 13:13:59 -0400 Subject: [PATCH 03/25] Make lenses for EvaluatingState. --- semantic.cabal | 2 ++ src/Analysis/Abstract/Evaluating.hs | 15 +++++++++------ 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 81a620766..219a5589e 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -161,6 +161,8 @@ library , hashable , kdt , mersenne-random-pure64 + , microlens + , microlens-th , mtl , network , network-uri diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 9116d4d32..6eb3596e3 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Evaluating ( Evaluating , findValue @@ -16,6 +16,7 @@ import Data.Abstract.Module import Data.Abstract.ModuleTable import qualified Data.IntMap as IntMap import qualified Data.Map.Monoidal as Monoidal +import Lens.Micro.TH import Prelude hiding (fail) import Prologue @@ -44,13 +45,15 @@ type EvaluatingEffects term value ] data EvaluatingState term value = EvaluatingState - { environment :: EnvironmentFor value - , heap :: HeapFor value - , modules :: ModuleTable (EnvironmentFor value, value) - , exports :: ExportsFor value - , jumps :: IntMap.IntMap term + { _environment :: EnvironmentFor value + , _heap :: HeapFor value + , _modules :: ModuleTable (EnvironmentFor value, value) + , _exports :: ExportsFor value + , _jumps :: IntMap.IntMap term } +makeLenses ''EvaluatingState + -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) value)) From bc89aa960a2b797077f1cffcdb6a7a80e0adbaf2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 13:50:43 -0400 Subject: [PATCH 04/25] Define a setter action. --- src/Analysis/Abstract/Evaluating.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 6eb3596e3..80ad9ceec 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -16,6 +16,7 @@ import Data.Abstract.Module import Data.Abstract.ModuleTable import qualified Data.IntMap as IntMap import qualified Data.Map.Monoidal as Monoidal +import Lens.Micro import Lens.Micro.TH import Prelude hiding (fail) import Prologue @@ -54,6 +55,10 @@ data EvaluatingState term value = EvaluatingState makeLenses ''EvaluatingState +(.=) :: (Effectful m, Member (State s) effects) => ASetter s s a b -> b -> m effects () +lens .= val = raise (modify (lens .~ val)) + + -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) value)) From adaeb50be1246f9e359c7251d7a8cc559fef5848 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 13:53:20 -0400 Subject: [PATCH 05/25] Define a getter action. --- src/Analysis/Abstract/Evaluating.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 80ad9ceec..2bdc24082 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -58,6 +58,9 @@ makeLenses ''EvaluatingState (.=) :: (Effectful m, Member (State s) effects) => ASetter s s a b -> b -> m effects () lens .= val = raise (modify (lens .~ val)) +view :: (Effectful m, Member (State s) effects) => Getting a s a -> m effects a +view lens = raise ((^. lens) <$> get) + -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) From a56d755e8c0641b8c2cdccc987ecb4d91fd8596b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 15:12:36 -0400 Subject: [PATCH 06/25] Specialize .= and view to Evaluating. --- 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 2bdc24082..8390f7274 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -55,10 +55,10 @@ data EvaluatingState term value = EvaluatingState makeLenses ''EvaluatingState -(.=) :: (Effectful m, Member (State s) effects) => ASetter s s a b -> b -> m effects () +(.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects () lens .= val = raise (modify (lens .~ val)) -view :: (Effectful m, Member (State s) effects) => Getting a s a -> m effects a +view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a view lens = raise ((^. lens) <$> get) From e9b889ac0c4ae535b3c6fb03651221e9faec8462 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 15:12:54 -0400 Subject: [PATCH 07/25] Define an analogue of localState. --- src/Analysis/Abstract/Evaluating.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 8390f7274..732347a87 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -61,6 +61,9 @@ lens .= val = raise (modify (lens .~ val)) view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a view lens = raise ((^. lens) <$> get) +localEvaluatingState :: Member (State (EvaluatingState term value)) effects => (EvaluatingState term value -> EvaluatingState term value) -> Evaluating term value effects a -> Evaluating term value effects a +localEvaluatingState f = raise . localState f . lower + -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) From b80f925ec6a56efa46293ad0cc13862b7ddda7a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 15:13:04 -0400 Subject: [PATCH 08/25] Spacing. --- src/Analysis/Abstract/Evaluating.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 732347a87..bd00394c6 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -55,6 +55,7 @@ data EvaluatingState term value = EvaluatingState makeLenses ''EvaluatingState + (.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects () lens .= val = raise (modify (lens .~ val)) From 1fd87793496f028d75d63b1b05d6fdb32115e131 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 15:29:32 -0400 Subject: [PATCH 09/25] Define Semigroup & Monoid instances for EvaluatingState. --- src/Analysis/Abstract/Evaluating.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index bd00394c6..5a440ee2a 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -53,6 +53,13 @@ data EvaluatingState term value = EvaluatingState , _jumps :: IntMap.IntMap term } +instance (Ord (LocationFor value), Semigroup (CellFor value)) => Semigroup (EvaluatingState term value) where + EvaluatingState e1 h1 m1 x1 j1 <> EvaluatingState e2 h2 m2 x2 j2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2) + +instance (Ord (LocationFor value), Semigroup (CellFor value)) => Monoid (EvaluatingState term value) where + mempty = EvaluatingState mempty mempty mempty mempty mempty + mappend = (<>) + makeLenses ''EvaluatingState From a9388ff1180e85cc7e69f20ea8ba68b84aa5a53d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 15:34:37 -0400 Subject: [PATCH 10/25] Use a single combined State type. --- src/Analysis/Abstract/Evaluating.hs | 50 +++++++++++++---------------- vendor/effects | 2 +- 2 files changed, 24 insertions(+), 28 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 5a440ee2a..b97650887 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -36,13 +36,9 @@ type EvaluatingEffects term value , Resumable (Unspecialized value) , Fail -- Failure with an error message , Reader [Module term] -- The stack of currently-evaluating modules. - , State (EnvironmentFor value) -- Environments (both local and global) - , State (HeapFor value) -- The heap , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules , Reader (EnvironmentFor value) -- Default environment used as a fallback in lookupEnv - , State (ModuleTable (EnvironmentFor value, value)) -- Cache of evaluated modules - , State (ExportsFor value) -- Exports (used to filter environments when they are imported) - , State (IntMap.IntMap term) -- For jumps + , State (EvaluatingState term value) -- Environment, heap, modules, exports, and jumps. ] data EvaluatingState term value = EvaluatingState @@ -76,55 +72,55 @@ localEvaluatingState f = raise . localState f . lower -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) value)) -findValue (((((v, _), _), _), _), _) = v +findValue = fst -- | Find the 'Environment' in the 'Final' result of running. findEnv :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> EnvironmentFor value -findEnv (((((_, env), _), _), _), _) = env +findEnv = _environment . snd -- | Find the 'Heap' in the 'Final' result of running. findHeap :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> Monoidal.Map (LocationFor value) (CellFor value) -findHeap (((((_, _), Heap heap), _), _), _) = heap +findHeap = unHeap . _heap . snd -instance Members '[Fail, State (IntMap.IntMap term)] effects => MonadControl term (Evaluating term value effects) where +instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where label term = do - m <- raise get + m <- view jumps let i = IntMap.size m - raise (put (IntMap.insert i term m)) + jumps .= IntMap.insert i term m pure i - goto label = IntMap.lookup label <$> raise get >>= maybe (fail ("unknown label: " <> show label)) pure + goto label = IntMap.lookup label <$> view jumps >>= maybe (fail ("unknown label: " <> show label)) pure -instance Members '[ State (ExportsFor value) - , State (EnvironmentFor value) +instance Members '[ State (EvaluatingState term value) , Reader (EnvironmentFor value) - ] effects => MonadEnvironment value (Evaluating term value effects) where - getEnv = raise get - putEnv = raise . put - withEnv s = raise . localState s . lower + ] effects + => MonadEnvironment value (Evaluating term value effects) where + getEnv = view environment + putEnv = (environment .=) + withEnv s = localEvaluatingState (environment .~ s) defaultEnvironment = raise ask withDefaultEnvironment e = raise . local (const e) . lower - getExports = raise get - putExports = raise . put - withExports s = raise . localState s . lower + getExports = view exports + putExports = (exports .=) + withExports s = localEvaluatingState (exports .~ s) localEnv f a = do modifyEnv (f . Env.push) result <- a result <$ modifyEnv Env.pop -instance Member (State (HeapFor value)) effects => MonadHeap value (Evaluating term value effects) where - getHeap = raise get - putHeap = raise . put +instance Member (State (EvaluatingState term value)) effects => MonadHeap value (Evaluating term value effects) where + getHeap = view heap + putHeap = (heap .=) -instance Members '[Reader (ModuleTable [Module term]), State (ModuleTable (EnvironmentFor value, value))] effects => MonadModuleTable term value (Evaluating term value effects) where - getModuleTable = raise get - putModuleTable = raise . put +instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState term value)] effects => MonadModuleTable term value (Evaluating term value effects) where + getModuleTable = view modules + putModuleTable = (modules .=) askModuleTable = raise ask localModuleTable f a = raise (local f (lower a)) diff --git a/vendor/effects b/vendor/effects index 74c1ca98a..b888bc3e9 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 74c1ca98ae9007e64fdc3f819b7d096ff7f802f7 +Subproject commit b888bc3e91a218c9e803122c05d5a6d27fc0897b From 6b0b0f908d1bb28d4708c40b1a5d2c806bec415e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 26 Mar 2018 17:55:15 -0400 Subject: [PATCH 11/25] Tighten up the comments. --- src/Analysis/Abstract/Evaluating.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b97650887..49458ed6c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -34,11 +34,11 @@ deriving instance Member NonDet effects => MonadNonDet (Evaluating term value type EvaluatingEffects term value = '[ Resumable (ValueExc value) , Resumable (Unspecialized value) - , Fail -- Failure with an error message - , Reader [Module term] -- The stack of currently-evaluating modules. - , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules - , Reader (EnvironmentFor value) -- Default environment used as a fallback in lookupEnv - , State (EvaluatingState term value) -- Environment, heap, modules, exports, and jumps. + , Fail -- Failure with an error message + , Reader [Module term] -- The stack of currently-evaluating modules. + , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules + , Reader (EnvironmentFor value) -- Default environment used as a fallback in lookupEnv + , State (EvaluatingState term value) -- Environment, heap, modules, exports, and jumps. ] data EvaluatingState term value = EvaluatingState From ec972b1567456481b0d541822377fe64dc61e9c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:00:49 -0400 Subject: [PATCH 12/25] Define the lenses without TH. --- src/Analysis/Abstract/Evaluating.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 49458ed6c..8bd036587 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Evaluating ( Evaluating , findValue @@ -17,7 +17,6 @@ import Data.Abstract.ModuleTable import qualified Data.IntMap as IntMap import qualified Data.Map.Monoidal as Monoidal import Lens.Micro -import Lens.Micro.TH import Prelude hiding (fail) import Prologue @@ -56,7 +55,20 @@ instance (Ord (LocationFor value), Semigroup (CellFor value)) => Monoid (Evaluat mempty = EvaluatingState mempty mempty mempty mempty mempty mappend = (<>) -makeLenses ''EvaluatingState +environment :: Lens' (EvaluatingState term value) (EnvironmentFor value) +environment = lens _environment (\ s e -> s {_environment = e}) + +heap :: Lens' (EvaluatingState term value) (HeapFor value) +heap = lens _heap (\ s h -> s {_heap = h}) + +modules :: Lens' (EvaluatingState term value) (ModuleTable (EnvironmentFor value, value)) +modules = lens _modules (\ s m -> s {_modules = m}) + +exports :: Lens' (EvaluatingState term value) (ExportsFor value) +exports = lens _exports (\ s e -> s {_exports = e}) + +jumps :: Lens' (EvaluatingState term value) (IntMap.IntMap term) +jumps = lens _jumps (\ s j -> s {_jumps = j}) (.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects () From d596b0a7c6d54e178fe457e26b6af0fe749d98a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:01:35 -0400 Subject: [PATCH 13/25] :fire: the dependency on TH. --- semantic.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/semantic.cabal b/semantic.cabal index 219a5589e..af519198a 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -162,7 +162,6 @@ library , kdt , mersenne-random-pure64 , microlens - , microlens-th , mtl , network , network-uri From 7b90a0192bf2f37a4f438e9a0631460c5da85d34 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:03:26 -0400 Subject: [PATCH 14/25] Prefix the lenses instead of the fields. --- src/Analysis/Abstract/Evaluating.hs | 60 ++++++++++++++--------------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 8bd036587..bada92915 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -41,11 +41,11 @@ type EvaluatingEffects term value ] data EvaluatingState term value = EvaluatingState - { _environment :: EnvironmentFor value - , _heap :: HeapFor value - , _modules :: ModuleTable (EnvironmentFor value, value) - , _exports :: ExportsFor value - , _jumps :: IntMap.IntMap term + { environment :: EnvironmentFor value + , heap :: HeapFor value + , modules :: ModuleTable (EnvironmentFor value, value) + , exports :: ExportsFor value + , jumps :: IntMap.IntMap term } instance (Ord (LocationFor value), Semigroup (CellFor value)) => Semigroup (EvaluatingState term value) where @@ -55,20 +55,20 @@ instance (Ord (LocationFor value), Semigroup (CellFor value)) => Monoid (Evaluat mempty = EvaluatingState mempty mempty mempty mempty mempty mappend = (<>) -environment :: Lens' (EvaluatingState term value) (EnvironmentFor value) -environment = lens _environment (\ s e -> s {_environment = e}) +_environment :: Lens' (EvaluatingState term value) (EnvironmentFor value) +_environment = lens environment (\ s e -> s {environment = e}) -heap :: Lens' (EvaluatingState term value) (HeapFor value) -heap = lens _heap (\ s h -> s {_heap = h}) +_heap :: Lens' (EvaluatingState term value) (HeapFor value) +_heap = lens heap (\ s h -> s {heap = h}) -modules :: Lens' (EvaluatingState term value) (ModuleTable (EnvironmentFor value, value)) -modules = lens _modules (\ s m -> s {_modules = m}) +_modules :: Lens' (EvaluatingState term value) (ModuleTable (EnvironmentFor value, value)) +_modules = lens modules (\ s m -> s {modules = m}) -exports :: Lens' (EvaluatingState term value) (ExportsFor value) -exports = lens _exports (\ s e -> s {_exports = e}) +_exports :: Lens' (EvaluatingState term value) (ExportsFor value) +_exports = lens exports (\ s e -> s {exports = e}) -jumps :: Lens' (EvaluatingState term value) (IntMap.IntMap term) -jumps = lens _jumps (\ s j -> s {_jumps = j}) +_jumps :: Lens' (EvaluatingState term value) (IntMap.IntMap term) +_jumps = lens jumps (\ s j -> s {jumps = j}) (.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects () @@ -89,37 +89,37 @@ findValue = fst -- | Find the 'Environment' in the 'Final' result of running. findEnv :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> EnvironmentFor value -findEnv = _environment . snd +findEnv = environment . snd -- | Find the 'Heap' in the 'Final' result of running. findHeap :: (effects ~ RequiredEffects term value (Evaluating term value effects)) => Final effects value -> Monoidal.Map (LocationFor value) (CellFor value) -findHeap = unHeap . _heap . snd +findHeap = unHeap . heap . snd instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where label term = do - m <- view jumps + m <- view _jumps let i = IntMap.size m - jumps .= IntMap.insert i term m + _jumps .= IntMap.insert i term m pure i - goto label = IntMap.lookup label <$> view jumps >>= maybe (fail ("unknown label: " <> show label)) pure + goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure instance Members '[ State (EvaluatingState term value) , Reader (EnvironmentFor value) ] effects => MonadEnvironment value (Evaluating term value effects) where - getEnv = view environment - putEnv = (environment .=) - withEnv s = localEvaluatingState (environment .~ s) + getEnv = view _environment + putEnv = (_environment .=) + withEnv s = localEvaluatingState (_environment .~ s) defaultEnvironment = raise ask withDefaultEnvironment e = raise . local (const e) . lower - getExports = view exports - putExports = (exports .=) - withExports s = localEvaluatingState (exports .~ s) + getExports = view _exports + putExports = (_exports .=) + withExports s = localEvaluatingState (_exports .~ s) localEnv f a = do modifyEnv (f . Env.push) @@ -127,12 +127,12 @@ instance Members '[ State (EvaluatingState term value) result <$ modifyEnv Env.pop instance Member (State (EvaluatingState term value)) effects => MonadHeap value (Evaluating term value effects) where - getHeap = view heap - putHeap = (heap .=) + getHeap = view _heap + putHeap = (_heap .=) instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState term value)] effects => MonadModuleTable term value (Evaluating term value effects) where - getModuleTable = view modules - putModuleTable = (modules .=) + getModuleTable = view _modules + putModuleTable = (_modules .=) askModuleTable = raise ask localModuleTable f a = raise (local f (lower a)) From 541568e16fe3e65eef4781c02ba4e7fdda31a4be Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:04:55 -0400 Subject: [PATCH 15/25] Bump effects to master. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index b888bc3e9..215ac5be5 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit b888bc3e91a218c9e803122c05d5a6d27fc0897b +Subproject commit 215ac5be57258a786959dac391db6bef83a70f28 From ee2a948186e0521b27f879a97328134cf1fd5ec8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:05:22 -0400 Subject: [PATCH 16/25] Use gets to view state. --- src/Analysis/Abstract/Evaluating.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index bada92915..cc3993bd3 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -75,7 +75,7 @@ _jumps = lens jumps (\ s j -> s {jumps = j}) lens .= val = raise (modify (lens .~ val)) view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a -view lens = raise ((^. lens) <$> get) +view lens = raise (gets (^. lens)) localEvaluatingState :: Member (State (EvaluatingState term value)) effects => (EvaluatingState term value -> EvaluatingState term value) -> Evaluating term value effects a -> Evaluating term value effects a localEvaluatingState f = raise . localState f . lower From e40b34d69166347c835c60abfe436317808921d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:08:28 -0400 Subject: [PATCH 17/25] Export EvaluatingState. --- src/Analysis/Abstract/Evaluating.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index cc3993bd3..a9b5e0917 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Evaluating ( Evaluating +, EvaluatingState(..) , findValue , findEnv , findHeap From 7a10eabfd7351570b3752fee980506d166f2ae83 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:14:25 -0400 Subject: [PATCH 18/25] :fire: an unused language pragma. --- test/SpecHelpers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 0f2350da0..10fa53f79 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators, TypeApplications #-} +{-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators #-} module SpecHelpers ( module X , diffFilePaths From b8d714af281c2b6e0192cec06c36532a182fc958 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:23:26 -0400 Subject: [PATCH 19/25] Use the EvaluatingState fields directly. --- test/Analysis/Go/Spec.hs | 7 ++----- test/Analysis/PHP/Spec.hs | 26 +++++++++++--------------- test/Analysis/Python/Spec.hs | 10 +++++----- test/Analysis/Ruby/Spec.hs | 12 ++++++------ test/Analysis/TypeScript/Spec.hs | 8 ++++---- test/SpecHelpers.hs | 2 +- 6 files changed, 29 insertions(+), 36 deletions(-) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 8042946bf..b728d6d1a 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -2,9 +2,6 @@ module Analysis.Go.Spec (spec) where import Data.Abstract.Value -import Data.Map -import Data.Either - import SpecHelpers @@ -12,7 +9,7 @@ spec :: Spec spec = parallel $ do describe "evalutes Go" $ do it "imports and wildcard imports" $ do - env <- findEnv <$> evaluate "main.go" + env <- environment . snd <$> evaluate "main.go" env `shouldBe` [ (qualifiedName ["foo", "New"], addr 0) , (qualifiedName ["Rab"], addr 1) , (qualifiedName ["Bar"], addr 2) @@ -20,7 +17,7 @@ spec = parallel $ do ] it "imports with aliases (and side effects only)" $ do - env <- findEnv <$> evaluate "main1.go" + env <- environment . snd <$> evaluate "main1.go" env `shouldBe` [ (qualifiedName ["f", "New"], addr 0) , (qualifiedName ["main"], addr 3) -- addr 3 is due to side effects of -- eval'ing `import _ "./bar"` which diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index a2e8ed80c..e100c48ee 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -2,9 +2,6 @@ module Analysis.PHP.Spec (spec) where import Data.Abstract.Value -import Data.Map -import Data.Map.Monoidal as Map - import SpecHelpers @@ -12,27 +9,26 @@ spec :: Spec spec = parallel $ do describe "PHP" $ do it "evaluates include and require" $ do - env <- findEnv <$> evaluate "main.php" + env <- environment . snd <$> evaluate "main.php" env `shouldBe` [ (name "foo", addr 0) , (name "bar", addr 1) ] it "evaluates include_once and require_once" $ do - env <- findEnv <$> evaluate "main_once.php" + env <- environment . snd <$> evaluate "main_once.php" env `shouldBe` [ (name "foo", addr 0) , (name "bar", addr 1) ] it "evaluates namespaces" $ do - res <- evaluate "namespaces.php" - findEnv res `shouldBe` [ (name "NS1", addr 0) - , (name "Foo", addr 6) ] + res <- snd <$> evaluate "namespaces.php" + environment res `shouldBe` [ (name "NS1", addr 0) + , (name "Foo", addr 6) ] - let heap = findHeap res - Map.lookup (Precise 0) heap `shouldBe` ns "NS1" [ (name "Sub1", addr 1) - , (name "b", addr 4) - , (name "c", addr 5) - ] - Map.lookup (Precise 1) heap `shouldBe` ns "Sub1" [ (name "Sub2", addr 2) ] - Map.lookup (Precise 2) heap `shouldBe` ns "Sub2" [ (name "f", addr 3) ] + heapLookup (Address (Precise 0)) (heap res) `shouldBe` ns "NS1" [ (name "Sub1", addr 1) + , (name "b", addr 4) + , (name "c", addr 5) + ] + heapLookup (Address (Precise 1)) (heap res) `shouldBe` ns "Sub1" [ (name "Sub2", addr 2) ] + heapLookup (Address (Precise 2)) (heap res) `shouldBe` ns "Sub2" [ (name "f", addr 3) ] where ns n = Just . Latest . Just . injValue . Namespace (name n) diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 229ee35a3..6ca0e3976 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -11,29 +11,29 @@ spec :: Spec spec = parallel $ do describe "evalutes Python" $ do it "imports" $ do - env <- findEnv <$> evaluate "main.py" + env <- environment . snd <$> evaluate "main.py" env `shouldBe` [ (qualifiedName ["a", "foo"], addr 0) , (qualifiedName ["b", "c", "baz"], addr 1) ] it "imports with aliases" $ do - env <- findEnv <$> evaluate "main1.py" + env <- environment . snd <$> evaluate "main1.py" env `shouldBe` [ (qualifiedName ["b", "foo"], addr 0) , (qualifiedName ["e", "baz"], addr 1) ] it "imports using 'from' syntax" $ do - env <- findEnv <$> evaluate "main2.py" + env <- environment . snd <$> evaluate "main2.py" env `shouldBe` [ (qualifiedName ["foo"], addr 0) , (qualifiedName ["bar"], addr 1) ] it "subclasses" $ do - v <- findValue <$> evaluate "subclass.py" + v <- fst <$> evaluate "subclass.py" v `shouldBe` Right (Right (Right (injValue (String "\"bar\"")))) it "handles multiple inheritance left-to-right" $ do - v <- findValue <$> evaluate "multiple_inheritance.py" + v <- fst <$> evaluate "multiple_inheritance.py" v `shouldBe` Right (Right (Right (injValue (String "\"foo!\"")))) where diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index b8301a1b2..e66278d8d 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -12,28 +12,28 @@ spec :: Spec spec = parallel $ do describe "evalutes Ruby" $ do it "require_relative" $ do - env <- findEnv <$> evaluate "main.rb" + env <- environment . snd <$> evaluate "main.rb" let expectedEnv = [ (qualifiedName ["Object"], addr 0) , (qualifiedName ["foo"], addr 3)] env `shouldBe` expectedEnv it "load" $ do - env <- findEnv <$> evaluate "load.rb" + env <- environment . snd <$> evaluate "load.rb" let expectedEnv = [ (qualifiedName ["Object"], addr 0) , (qualifiedName ["foo"], addr 3) ] env `shouldBe` expectedEnv it "load wrap" $ do res <- evaluate "load-wrap.rb" - findValue res `shouldBe` Left "free variable: \"foo\"" - findEnv res `shouldBe` [(qualifiedName ["Object"], addr 0)] + fst res `shouldBe` Left "free variable: \"foo\"" + environment (snd res) `shouldBe` [(qualifiedName ["Object"], addr 0)] it "subclass" $ do - res <- findValue <$> evaluate "subclass.rb" + res <- fst <$> evaluate "subclass.rb" res `shouldBe` Right (Right (Right (injValue (String "\"\"")))) it "has prelude" $ do - res <- findValue <$> evaluate "preluded.rb" + res <- fst <$> evaluate "preluded.rb" res `shouldBe` Right (Right (Right (injValue (String "\"\"")))) where diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 4b59ecc5a..395278e27 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -11,11 +11,11 @@ spec :: Spec spec = parallel $ do describe "evalutes TypeScript" $ do it "imports with aliased symbols" $ do - env <- findEnv <$> evaluate "main.ts" + env <- environment . snd <$> evaluate "main.ts" env `shouldBe` [ (qualifiedName ["bar"], addr 0) ] it "imports with qualified names" $ do - env <- findEnv <$> evaluate "main1.ts" + env <- environment . snd <$> evaluate "main1.ts" env `shouldBe` [ (qualifiedName ["b", "baz"], addr 0) , (qualifiedName ["b", "foo"], addr 2) , (qualifiedName ["z", "baz"], addr 0) @@ -23,11 +23,11 @@ spec = parallel $ do ] it "side effect only imports" $ do - env <- findEnv <$> evaluate "main2.ts" + env <- environment . snd <$> evaluate "main2.ts" env `shouldBe` mempty it "fails exporting symbols not defined in the module" $ do - v <- findValue <$> evaluate "bad-export.ts" + v <- fst <$> evaluate "bad-export.ts" v `shouldBe` Left "module \"foo\" does not export \"pip\"" where diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 10fa53f79..71b10063f 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -9,7 +9,7 @@ module SpecHelpers ( , Verbatim(..) , ) where -import Analysis.Abstract.Evaluating as X (findValue, findEnv, findHeap) +import Analysis.Abstract.Evaluating as X (EvaluatingState(..)) import Data.Abstract.Address as X import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.Heap as X From e9cac9d0c22a6295843ca9bae97393829998bdab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:24:28 -0400 Subject: [PATCH 20/25] :fire: find*, in favour of EvaluatingState fields. --- src/Analysis/Abstract/Evaluating.hs | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index a9b5e0917..d821d09de 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -2,9 +2,6 @@ module Analysis.Abstract.Evaluating ( Evaluating , EvaluatingState(..) -, findValue -, findEnv -, findHeap ) where import Control.Abstract.Analysis @@ -82,22 +79,6 @@ localEvaluatingState :: Member (State (EvaluatingState term value)) effects => ( localEvaluatingState f = raise . localState f . lower --- | Find the value in the 'Final' result of running. -findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) - => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) value)) -findValue = fst - --- | Find the 'Environment' in the 'Final' result of running. -findEnv :: (effects ~ RequiredEffects term value (Evaluating term value effects)) - => Final effects value -> EnvironmentFor value -findEnv = environment . snd - --- | Find the 'Heap' in the 'Final' result of running. -findHeap :: (effects ~ RequiredEffects term value (Evaluating term value effects)) - => Final effects value -> Monoidal.Map (LocationFor value) (CellFor value) -findHeap = unHeap . heap . snd - - instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where label term = do m <- view _jumps From 107274d4dd5afb3d10debbbaf6c91ddd0a173564 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:25:57 -0400 Subject: [PATCH 21/25] :fire: some redundant imports. --- 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 d821d09de..a6049288e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -9,11 +9,9 @@ import Control.Monad.Effect import Data.Abstract.Configuration import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import Data.Abstract.Heap import Data.Abstract.Module import Data.Abstract.ModuleTable import qualified Data.IntMap as IntMap -import qualified Data.Map.Monoidal as Monoidal import Lens.Micro import Prelude hiding (fail) import Prologue From bf2bab5255b78a422f825783d82c2015082c6106 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 27 Mar 2018 15:41:43 -0400 Subject: [PATCH 22/25] Modify the state strictly. --- src/Analysis/Abstract/Evaluating.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index a6049288e..e4e9ea78d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -68,7 +68,7 @@ _jumps = lens jumps (\ s j -> s {jumps = j}) (.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects () -lens .= val = raise (modify (lens .~ val)) +lens .= val = raise (modify' (lens .~ val)) view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a view lens = raise (gets (^. lens)) From e1dabed4560e66919940fae88a56d99c5e75716b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 28 Mar 2018 07:56:11 -0400 Subject: [PATCH 23/25] Derive Eq, Ord, & Show instances for EvaluatingState. --- src/Analysis/Abstract/Evaluating.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index e4e9ea78d..13d4b4e9d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -44,6 +44,10 @@ data EvaluatingState term value = EvaluatingState , jumps :: IntMap.IntMap term } +deriving instance (Eq (CellFor value), Eq (LocationFor value), Eq term, Eq value) => Eq (EvaluatingState term value) +deriving instance (Ord (CellFor value), Ord (LocationFor value), Ord term, Ord value) => Ord (EvaluatingState term value) +deriving instance (Show (CellFor value), Show (LocationFor value), Show term, Show value) => Show (EvaluatingState term value) + instance (Ord (LocationFor value), Semigroup (CellFor value)) => Semigroup (EvaluatingState term value) where EvaluatingState e1 h1 m1 x1 j1 <> EvaluatingState e2 h2 m2 x2 j2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2) From f7afd2c4b48bc26cea1c352610dcb1d57fb71e18 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 28 Mar 2018 08:22:04 -0400 Subject: [PATCH 24/25] Only reset a single field using localEvaluatingState. --- src/Analysis/Abstract/Evaluating.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 13d4b4e9d..01295d439 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Evaluating ( Evaluating , EvaluatingState(..) @@ -77,8 +77,12 @@ lens .= val = raise (modify' (lens .~ val)) view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a view lens = raise (gets (^. lens)) -localEvaluatingState :: Member (State (EvaluatingState term value)) effects => (EvaluatingState term value -> EvaluatingState term value) -> Evaluating term value effects a -> Evaluating term value effects a -localEvaluatingState f = raise . localState f . lower +localEvaluatingState :: Member (State (EvaluatingState term value)) effects => Lens' (EvaluatingState term value) prj -> (prj -> prj) -> Evaluating term value effects a -> Evaluating term value effects a +localEvaluatingState lens f action = do + original <- view lens + raise (modify' (lens %~ f)) + v <- action + v <$ raise (modify' (lens .~ original)) instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where @@ -96,14 +100,14 @@ instance Members '[ State (EvaluatingState term value) => MonadEnvironment value (Evaluating term value effects) where getEnv = view _environment putEnv = (_environment .=) - withEnv s = localEvaluatingState (_environment .~ s) + withEnv s = localEvaluatingState _environment (const s) defaultEnvironment = raise ask withDefaultEnvironment e = raise . local (const e) . lower getExports = view _exports putExports = (_exports .=) - withExports s = localEvaluatingState (_exports .~ s) + withExports s = localEvaluatingState _exports (const s) localEnv f a = do modifyEnv (f . Env.push) From 1d3c09a9d29f28ab108e867138ba0374961554f0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 28 Mar 2018 08:56:02 -0400 Subject: [PATCH 25/25] Use .= to define localEvaluatingState. --- 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 260acd0eb..d41db1d5a 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -80,9 +80,9 @@ view lens = raise (gets (^. lens)) localEvaluatingState :: Member (State (EvaluatingState term value)) effects => Lens' (EvaluatingState term value) prj -> (prj -> prj) -> Evaluating term value effects a -> Evaluating term value effects a localEvaluatingState lens f action = do original <- view lens - raise (modify' (lens %~ f)) + lens .= f original v <- action - v <$ raise (modify' (lens .~ original)) + v <$ lens .= original instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where