mirror of
https://github.com/github/semantic.git
synced 2024-12-29 18:06:14 +03:00
Swap the module table ordering.
This commit is contained in:
Rob Rix
parent
d47d91fc32
commit
956959ac07
@ -10,7 +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
|
||||
{ heap :: Heap address (Cell address) value
|
||||
, modules :: ModuleTable (Maybe (address, Environment address))
|
||||
, modules :: ModuleTable (Maybe (Environment address, address))
|
||||
}
|
||||
|
||||
deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value)
|
||||
@ -18,14 +18,15 @@ deriving instance (Ord (Cell address value), Ord address, Ord value) => Ord
|
||||
deriving instance (Show (Cell address value), Show address, Show value) => Show (EvaluatingState address value)
|
||||
|
||||
|
||||
evaluating :: Evaluator address value
|
||||
evaluating :: Effects effects
|
||||
=> Evaluator address value
|
||||
( Fresh
|
||||
': State (Heap address (Cell address) value)
|
||||
': State (ModuleTable (Maybe (address, Environment address)))
|
||||
': State (ModuleTable (Maybe (Environment address, address)))
|
||||
': effects) result
|
||||
-> Evaluator address value effects (result, EvaluatingState address value)
|
||||
evaluating
|
||||
= fmap (\ ((result, heap), modules) -> (result, EvaluatingState heap modules))
|
||||
. runState lowerBound -- State (ModuleTable (Maybe (address, Environment address)))
|
||||
= fmap (\ (modules, (heap, result)) -> (result, EvaluatingState heap modules))
|
||||
. runState lowerBound -- State (ModuleTable (Maybe (Environment address, address)))
|
||||
. runState lowerBound -- State (Heap address (Cell address) value)
|
||||
. runFresh 0
|
||||
|
||||
@ -26,7 +26,7 @@ import Data.Language
|
||||
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.
|
||||
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (address, Environment address)))
|
||||
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (Environment address, address)))
|
||||
lookupModule = sendModules . Lookup
|
||||
|
||||
-- | Resolve a list of module paths to a possible module table entry.
|
||||
@ -40,19 +40,19 @@ listModulesInDir = sendModules . List @address @value
|
||||
-- | Require/import another module by name and return its environment and value.
|
||||
--
|
||||
-- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
|
||||
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
|
||||
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, address))
|
||||
require path = lookupModule path >>= maybeM (load path)
|
||||
|
||||
-- | Load another module by name and return its environment and value.
|
||||
--
|
||||
-- Always loads/evaluates.
|
||||
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
|
||||
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, address))
|
||||
load path = sendModules (Load path)
|
||||
|
||||
|
||||
data Modules address value (m :: * -> *) return where
|
||||
Load :: ModulePath -> Modules address value m (Maybe (address, Environment address))
|
||||
Lookup :: ModulePath -> Modules address value m (Maybe (Maybe (address, Environment address)))
|
||||
Load :: ModulePath -> Modules address value m (Maybe (Environment address, address))
|
||||
Lookup :: ModulePath -> Modules address value m (Maybe (Maybe (Environment address, address)))
|
||||
Resolve :: [FilePath] -> Modules address value m (Maybe ModulePath)
|
||||
List :: FilePath -> Modules address value m [ModulePath]
|
||||
|
||||
@ -61,11 +61,11 @@ sendModules = send
|
||||
|
||||
runModules :: forall term address value effects a
|
||||
. ( Member (Resumable (LoadError address value)) effects
|
||||
, Member (State (ModuleTable (Maybe (address, Environment address)))) effects
|
||||
, Member (State (ModuleTable (Maybe (Environment address, address)))) effects
|
||||
, Member Trace effects
|
||||
, Effects effects
|
||||
)
|
||||
=> (Module term -> Evaluator address value (Modules address value ': effects) (address, Environment address))
|
||||
=> (Module term -> Evaluator address value (Modules address value ': effects) (Environment address, address))
|
||||
-> Evaluator address value (Modules address value ': effects) a
|
||||
-> Evaluator address value (Reader (ModuleTable (NonEmpty (Module term))) ': effects) a
|
||||
runModules evaluateModule = go
|
||||
@ -90,22 +90,22 @@ runModules evaluateModule = go
|
||||
pure (find isMember names)
|
||||
List dir -> modulePathsInDir dir <$> askModuleTable @term)
|
||||
|
||||
getModuleTable :: Member (State (ModuleTable (Maybe (address, Environment address)))) effects => Evaluator address value effects (ModuleTable (Maybe (address, Environment address)))
|
||||
getModuleTable :: Member (State (ModuleTable (Maybe (Environment address, address)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, address)))
|
||||
getModuleTable = get
|
||||
|
||||
cacheModule :: Member (State (ModuleTable (Maybe (address, Environment address)))) effects => ModulePath -> Maybe (address, Environment address) -> Evaluator address value effects (Maybe (address, Environment address))
|
||||
cacheModule :: Member (State (ModuleTable (Maybe (Environment address, address)))) effects => ModulePath -> Maybe (Environment address, address) -> Evaluator address value effects (Maybe (Environment address, address))
|
||||
cacheModule path result = modify' (ModuleTable.insert path result) $> result
|
||||
|
||||
askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module term)))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module term)))
|
||||
askModuleTable = ask
|
||||
|
||||
|
||||
newtype Merging m address value = Merging { runMerging :: m (Maybe (address, Environment address)) }
|
||||
newtype Merging m address value = Merging { runMerging :: m (Maybe (Environment address, 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) (v, env2) = (v, mergeEnvs env1 env2)
|
||||
mergeJusts (env1, _) (env2, v) = (mergeEnvs env1 env2, v)
|
||||
|
||||
instance Applicative m => Monoid (Merging m address value) where
|
||||
mappend = (<>)
|
||||
@ -114,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 (address, Environment address))
|
||||
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (Environment address, address))
|
||||
|
||||
deriving instance Eq (LoadError address value resume)
|
||||
deriving instance Show (LoadError address value resume)
|
||||
@ -123,7 +123,7 @@ instance Show1 (LoadError address value) where
|
||||
instance Eq1 (LoadError address value) where
|
||||
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
|
||||
|
||||
moduleNotFound :: forall address value effects . Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
|
||||
moduleNotFound :: forall address value effects . Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, address))
|
||||
moduleNotFound = throwResumable . ModuleNotFound @address @value
|
||||
|
||||
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
|
||||
|
||||
@ -68,6 +68,7 @@ evaluatePackageWith :: forall address 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 address inner'
|
||||
, Declarations term
|
||||
, Effects outer
|
||||
, Evaluatable (Base term)
|
||||
, Foldable (Cell address)
|
||||
, FreeVariables term
|
||||
@ -79,7 +80,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer
|
||||
, Member (Resumable ResolutionError) outer
|
||||
, Member (Resumable (Unspecialized value)) outer
|
||||
, Member (State (Heap address (Cell address) value)) outer
|
||||
, Member (State (ModuleTable (Maybe (address, Environment address)))) outer
|
||||
, Member (State (ModuleTable (Maybe (Environment address, address)))) outer
|
||||
, Member Trace outer
|
||||
, Recursive term
|
||||
, Reducer value (Cell address value)
|
||||
@ -91,7 +92,7 @@ evaluatePackageWith :: forall address term value inner inner' inner'' outer
|
||||
=> (SubtermAlgebra Module term (TermEvaluator term address value inner address) -> SubtermAlgebra Module term (TermEvaluator term address value inner address))
|
||||
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef address)))
|
||||
-> Package term
|
||||
-> TermEvaluator term address value outer [(address, Environment address)]
|
||||
-> TermEvaluator term address value outer [(Environment address, address)]
|
||||
evaluatePackageWith analyzeModule analyzeTerm package
|
||||
= runReader (packageInfo package)
|
||||
. runReader lowerBound
|
||||
@ -115,20 +116,20 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
||||
. raiseHandler runReturn
|
||||
. raiseHandler runLoopControl
|
||||
|
||||
evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (address, Environment address)
|
||||
evaluateEntryPoint :: Environment address -> ModulePath -> Maybe Name -> TermEvaluator term address value inner'' (Environment address, address)
|
||||
evaluateEntryPoint preludeEnv m sym = runInModule preludeEnv (ModuleInfo m) . TermEvaluator $ do
|
||||
addr <- box unit -- TODO don't *always* allocate - use maybeM instead
|
||||
(ptr, env) <- fromMaybe (addr, emptyEnv) <$> require m
|
||||
(env, ptr) <- fromMaybe (emptyEnv, addr) <$> require m
|
||||
bindAll env
|
||||
maybe (pure ptr) ((`call` []) <=< deref <=< variable) sym
|
||||
|
||||
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule emptyEnv)) $ do
|
||||
(_, builtinsEnv) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> box unit))
|
||||
second (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude
|
||||
(builtinsEnv, _) <- runInModule emptyEnv moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> box unit))
|
||||
first (mergeEnvs builtinsEnv) <$> evalModule builtinsEnv prelude
|
||||
|
||||
withPrelude Nothing f = f emptyEnv
|
||||
withPrelude (Just prelude) f = do
|
||||
(_, preludeEnv) <- evalPrelude prelude
|
||||
(preludeEnv, _) <- evalPrelude prelude
|
||||
f preludeEnv
|
||||
|
||||
|
||||
@ -166,10 +167,10 @@ instance Show1 EvalError where
|
||||
throwEvalError :: (Effectful m, Member (Resumable EvalError) effects) => EvalError resume -> m effects resume
|
||||
throwEvalError = throwResumable
|
||||
|
||||
runEvalError :: Effectful m => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a)
|
||||
runEvalError :: (Effectful m, Effects effects) => m (Resumable EvalError ': effects) a -> m effects (Either (SomeExc EvalError) a)
|
||||
runEvalError = runResumable
|
||||
|
||||
runEvalErrorWith :: Effectful m => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a
|
||||
runEvalErrorWith :: (Effectful m, Effects effects) => (forall resume . EvalError resume -> m effects resume) -> m (Resumable EvalError ': effects) a -> m effects a
|
||||
runEvalErrorWith = runResumableWith
|
||||
|
||||
|
||||
@ -185,10 +186,10 @@ instance Eq1 (Unspecialized a) where
|
||||
instance Show1 (Unspecialized a) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
|
||||
runUnspecialized :: Effectful (m value) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a)
|
||||
runUnspecialized :: (Effectful (m value), Effects effects) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects (Either (SomeExc (Unspecialized value)) a)
|
||||
runUnspecialized = runResumable
|
||||
|
||||
runUnspecializedWith :: Effectful (m value) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a
|
||||
runUnspecializedWith :: (Effectful (m value), Effects effects) => (forall resume . Unspecialized value resume -> m value effects resume) -> m value (Resumable (Unspecialized value) ': effects) a -> m value effects a
|
||||
runUnspecializedWith = runResumableWith
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user