From db879fe1f69f5a9fca87a07a185f73955fcdb127 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 2 Mar 2018 14:36:53 -0800 Subject: [PATCH] Store the environment in the linker instead of an Interface.Value --- src/Analysis/Abstract/Evaluating.hs | 13 ++++----- src/Data/Abstract/Value.hs | 9 +++++++ src/Data/Syntax/Declaration.hs | 42 +++++++++++++++-------------- 3 files changed, 38 insertions(+), 26 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 32b691681..800b9e5d6 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -29,7 +29,7 @@ type Evaluating v , State (EnvironmentFor v) -- Global (imperative) environment , Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure) , Reader (Linker (Evaluator v)) -- Linker effects - , State (Linker v) -- Cache of evaluated modules + , State (Linker (EnvironmentFor v)) -- Cache of evaluated modules ] newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating v) v } @@ -37,19 +37,20 @@ newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating v) v } -- | Require/import another term/file and return an Effect. -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. -require :: forall v es. (Members (Evaluating v) es) => ModuleName -> Eff es v -require name = get @(Linker v) >>= maybe (load name) pure . linkerLookup name +require :: forall v es. (Members (Evaluating v) es, AbstractEnvironmentFor v) => ModuleName -> Eff es (EnvironmentFor v) +require name = get @(Linker (EnvironmentFor v)) >>= maybe (load name) pure . linkerLookup name -- | Load another term/file and return an Effect. -- -- Always loads/evaluates. -load :: forall v es. (Members (Evaluating v) es) => ModuleName -> Eff es v +load :: forall v es. (Members (Evaluating v) es, AbstractEnvironmentFor v) => ModuleName -> Eff es (EnvironmentFor v) load name = ask @(Linker (Evaluator v)) >>= maybe notFound evalAndCache . linkerLookup name where notFound = fail ("cannot find " <> show name) evalAndCache e = do v <- raiseEmbedded (runEvaluator e) - modify @(Linker v) (linkerInsert name v) - pure v + let env = environment v + modify @(Linker (EnvironmentFor v)) (linkerInsert name env) + pure env -- | Evaluate a term to a value. evaluate :: forall v term. diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index b0b9b40a5..9c4c6da3a 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -87,6 +87,15 @@ type family LocationFor value :: * where LocationFor Type.Type = Monovariant +type AbstractEnvironmentFor v = AbstractEnvironment (LocationFor v) v +class AbstractEnvironment l v | v -> l where + environment :: v -> EnvironmentFor v + +instance AbstractEnvironment l (Value l t) where + environment v + | Just (Interface _ env) <- prj v = env + | otherwise = mempty + -- | Extract the value back out of a cell. class CellValue l v where val :: Cell l v -> v diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index c5e603edb..e9217862c 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -15,7 +15,6 @@ import Diffing.Algorithm import Prelude hiding (fail) import Prologue import qualified Data.Abstract.Type as Type -import qualified Data.Abstract.Value as Value import qualified Data.Map as Map data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a } @@ -280,39 +279,38 @@ instance Eq1 Import2 where liftEq = genericLiftEq instance Ord1 Import2 where liftCompare = genericLiftCompare instance Show1 Import2 where liftShowsPrec = genericLiftShowsPrec -instance ( Semigroup (Cell l (Value l t)) - , Members (Evaluating (Value l t)) es - , Addressable l es - , Evaluatable es t (Value l t) (Base t) +instance ( Members (Evaluating v) es + , Evaluatable es t v (Base t) , Recursive t , FreeVariables t + , AbstractValue v + , AbstractEnvironmentFor v ) - => Evaluatable es t (Value l t) Import2 where + => Evaluatable es t v Import2 where eval (Import2 from alias xs) = do -- Capture current global environment - env <- get @(EnvironmentFor (Value l t)) + env <- get @(EnvironmentFor v) - -- Evaluate the import, the interface value we get back will contain an - -- environment but evaluating will have also have potentially updated the - -- global environment. - interface <- require @(Value l t) (qualifiedName (subterm from)) - (Interface _ modEnv) <- maybe (fail "expected an interface") pure (prj interface :: Maybe (Interface l t)) + -- TODO: We may or may not want to clear the globalEnv before requiring. + put @(EnvironmentFor v) mempty + + -- Evaluate the import to get it's environment. + -- (Evaluating will have also have potentially updated the global environment). + importedEnv <- require @v (qualifiedName (subterm from)) -- Restore previous global environment, adding the imported env let symbols = Map.fromList xs let prefix = qualifiedName (subterm alias) <> "." env' <- Map.foldrWithKey (\k v rest -> do if Map.null symbols + -- Copy over all symbols in the environment under their qualified names. then envInsert (prefix <> k) v <$> rest - else case Map.lookup k symbols of - Just symAlias -> envInsert symAlias v <$> rest - Nothing -> rest - ) (pure env) (unEnvironment modEnv) + -- Only copy over specified symbols, possibly aliasing them. + else maybe rest (\symAlias -> envInsert symAlias v <$> rest) (Map.lookup k symbols) + ) (pure env) (unEnvironment importedEnv) modify (const env') - pure interface - -instance Member Fail es => Evaluatable es t Type.Type Import2 + pure unit -- | A wildcard import @@ -325,9 +323,13 @@ instance Show1 WildcardImport where liftShowsPrec = genericLiftShowsPrec instance ( Members (Evaluating v) es , FreeVariables t + , AbstractEnvironmentFor v + , AbstractValue v ) => Evaluatable es t v WildcardImport where - eval (WildcardImport from _) = require @v (qualifiedName (subterm from)) + eval (WildcardImport from _) = put @(EnvironmentFor v) mempty + >> require @v (qualifiedName (subterm from)) + >> pure unit -- | An imported symbol