mirror of
https://github.com/github/semantic.git
synced 2024-11-28 10:15:55 +03:00
Run the environment state in evaluatePackageWith.
This commit is contained in:
Rob Rix
parent
3c81b7024a
commit
d4e6d87756
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user