From dcaf4ed61f65b8d0d0fbea04ba784da865fb3982 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 16 Mar 2018 16:34:39 -0400 Subject: [PATCH] There is no distinction between local and global environment now. --- src/Analysis/Abstract/Collecting.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 13 +++++------ src/Control/Abstract/Addressable.hs | 2 +- src/Control/Abstract/Analysis.hs | 4 ++-- src/Control/Abstract/Evaluator.hs | 34 ++++++++++++++--------------- src/Control/Abstract/Value.hs | 2 +- src/Data/Syntax/Declaration.hs | 12 +++++----- src/Data/Syntax/Statement.hs | 2 +- 8 files changed, 34 insertions(+), 37 deletions(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 6399b795e..54a975688 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -24,7 +24,7 @@ instance ( Effectful (m term value) , MonadEvaluator term value (m term value effects) ) => MonadEvaluator term value (Collecting m term value effects) where - getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getHeap + getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap instance ( Effectful (m term value) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 11740e577..ac6012b4c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -99,19 +99,18 @@ instance Members '[Fail, State (IntMap.IntMap term)] effects => MonadControl ter goto label = IntMap.lookup label <$> raise get >>= maybe (fail ("unknown label: " <> show label)) pure instance Members '[State (ExportsFor value), State (EnvironmentFor value)] effects => MonadEnvironment value (Evaluating term value effects) where - getGlobalEnv = raise get - putGlobalEnv = raise . put - withGlobalEnv s = raise . localState s . lower + getEnv = raise get + putEnv = raise . put + withEnv s = raise . localState s . lower getExports = raise get putExports = raise . put withExports s = raise . localState s . lower - askLocalEnv = raise get localEnv f a = do - modifyGlobalEnv (f . Env.push) + modifyEnv (f . Env.push) result <- a - result <$ modifyGlobalEnv Env.pop + result <$ modifyEnv Env.pop instance Member (State (HeapFor value)) effects => MonadHeap value (Evaluating term value effects) where getHeap = raise get @@ -125,7 +124,7 @@ instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentF localModuleTable f a = raise (local f (lower a)) instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where - getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getHeap + getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap instance ( Evaluatable (Base term) , FreeVariables term diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index df68ebe98..47171c135 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -25,7 +25,7 @@ lookupOrAlloc :: ( MonadAddressable (LocationFor value) value m ) => Name -> m (Address (LocationFor value) value) -lookupOrAlloc name = lookupLocalEnv name >>= maybe (alloc name) pure +lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( MonadAddressable (LocationFor value) value m diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 841e55661..9e3a305e0 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -45,7 +45,7 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value -- | Isolate the given action with an empty global environment and exports. isolate :: m a -> m a - isolate = withGlobalEnv mempty . withExports mempty + isolate = withEnv mempty . withExports mempty -- | Evaluate a term to a value using the semantics of the current analysis. -- @@ -79,7 +79,7 @@ load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup n evalAndCache [] = pure mempty evalAndCache (x:xs) = do void $ evaluateModule x - env <- filterEnv <$> getExports <*> getGlobalEnv + env <- filterEnv <$> getExports <*> getEnv modifyModuleTable (moduleTableInsert name env) (env <>) <$> evalAndCache xs diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 6bd62e92e..303be40d9 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -2,7 +2,7 @@ module Control.Abstract.Evaluator ( MonadEvaluator(..) , MonadEnvironment(..) - , modifyGlobalEnv + , modifyEnv , modifyExports , addExport , MonadHeap(..) @@ -45,12 +45,12 @@ class ( MonadControl term m -- | A 'Monad' abstracting local and global environments. class Monad m => MonadEnvironment value m | m -> value where - -- | Retrieve the global environment. - getGlobalEnv :: m (EnvironmentFor value) - -- | Set the global environment - putGlobalEnv :: EnvironmentFor value -> m () - -- | Sets the global environment for the lifetime of the given action. - withGlobalEnv :: EnvironmentFor value -> m a -> m a + -- | Retrieve the environment. + getEnv :: m (EnvironmentFor value) + -- | Set the environment. + putEnv :: EnvironmentFor value -> m () + -- | Sets the environment for the lifetime of the given action. + withEnv :: EnvironmentFor value -> m a -> m a -- | Get the global export state. getExports :: m (ExportsFor value) @@ -59,19 +59,17 @@ class Monad m => MonadEnvironment value m | m -> value where -- | Sets the global export state for the lifetime of the given action. withExports :: ExportsFor value -> m a -> m a - -- | Retrieve the local environment. - askLocalEnv :: m (EnvironmentFor value) -- | Run an action with a locally-modified environment. localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a - -- | Look a 'Name' up in the local environment. - lookupLocalEnv :: Name -> m (Maybe (Address (LocationFor value) value)) - lookupLocalEnv name = Env.lookup name <$> askLocalEnv + -- | Look a 'Name' up in the environment. + lookupEnv :: Name -> m (Maybe (Address (LocationFor value) value)) + lookupEnv name = Env.lookup name <$> getEnv - -- | Look up a 'Name' in the local environment, running an action with the resolved address (if any). + -- | Look up a 'Name' in the environment, running an action with the resolved address (if any). lookupWith :: (Address (LocationFor value) value -> m value) -> Name -> m (Maybe value) lookupWith with name = do - addr <- lookupLocalEnv name + addr <- lookupEnv name maybe (pure Nothing) (fmap Just . with) addr -- | Run a computation in a new local environment. @@ -80,10 +78,10 @@ localize = localEnv id -- | Update the global environment. -- TODO: RENAME ME BECAUSE MY NAME IS A LIE -modifyGlobalEnv :: MonadEnvironment value m => (EnvironmentFor value -> EnvironmentFor value) -> m () -modifyGlobalEnv f = do - env <- getGlobalEnv - putGlobalEnv $! f env +modifyEnv :: MonadEnvironment value m => (EnvironmentFor value -> EnvironmentFor value) -> m () +modifyEnv f = do + env <- getEnv + putEnv $! f env -- | Update the global export state. modifyExports :: MonadEnvironment value m => (ExportsFor value -> ExportsFor value) -> m () diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index eea3f9bb5..6df5f1943 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -221,7 +221,7 @@ instance ( Monad m abstract names (Subterm body _) = do l <- label body - injValue . Closure names l . Env.bindEnv (foldr Set.delete (freeVariables body) names) <$> askLocalEnv + injValue . Closure names l . Env.bindEnv (foldr Set.delete (freeVariables body) names) <$> getEnv apply op params = do Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 925809258..062f33613 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -23,7 +23,7 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Function where eval Function{..} = do (v, addr) <- letrec name (abstract (paramNames functionParameters) functionBody) - modifyGlobalEnv (Env.insert name addr) + modifyEnv (Env.insert name addr) pure v where paramNames = foldMap (pure . freeVariable . subterm) name = freeVariable (subterm functionName) @@ -44,7 +44,7 @@ instance Show1 Method where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Method where eval Method{..} = do (v, addr) <- letrec name (abstract (paramNames methodParameters) methodBody) - modifyGlobalEnv (Env.insert name addr) + modifyEnv (Env.insert name addr) pure v where paramNames = foldMap (pure . freeVariable . subterm) name = freeVariable (subterm methodName) @@ -148,9 +148,9 @@ instance Evaluatable Class where let name = freeVariable (subterm classIdentifier) (v, addr) <- letrec name $ do void $ subtermValue classBody - classEnv <- Env.head <$> askLocalEnv + classEnv <- Env.head <$> getEnv klass name classEnv - v <$ modifyGlobalEnv (Env.insert name addr) + v <$ modifyEnv (Env.insert name addr) data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) @@ -277,7 +277,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedImport where eval (QualifiedImport from alias xs) = do importedEnv <- isolate (require moduleName) - modifyGlobalEnv (mappend (Env.rename (renames importedEnv) importedEnv)) + modifyEnv (mappend (Env.rename (renames importedEnv) importedEnv)) unit where moduleName = freeVariable (subterm from) @@ -300,7 +300,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import from xs _) = do importedEnv <- isolate (require moduleName) - modifyGlobalEnv (mappend (renamed importedEnv)) + modifyEnv (mappend (renamed importedEnv)) unit where moduleName = freeVariable (subterm from) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 3201f4ebf..5502cfe79 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -96,7 +96,7 @@ instance Evaluatable Assignment where v <- subtermValue assignmentValue addr <- lookupOrAlloc name assign addr v - modifyGlobalEnv (Env.insert name addr) + modifyEnv (Env.insert name addr) pure v where name = freeVariable (subterm assignmentTarget)