mirror of
https://github.com/github/semantic.git
synced 2024-12-01 09:15:01 +03:00
Merge branch 'master' into charliesome/substitution
This commit is contained in:
Rob Rix
commit
e70d14bb52
@ -125,7 +125,7 @@ scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address (Cell
|
||||
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)
|
||||
|
||||
|
||||
caching :: Alternative f => TermEvaluator term address value (NonDet ': Reader (Cache term address (Cell address) value) ': State (Cache term address (Cell address) value) ': effects) a -> TermEvaluator term address value effects (f a, Cache term address (Cell address) value)
|
||||
caching :: (Alternative f, Effects effects) => TermEvaluator term address value (NonDet ': Reader (Cache term address (Cell address) value) ': State (Cache term address (Cell address) value) ': effects) a -> TermEvaluator term address value effects (Cache term address (Cell address) value, f a)
|
||||
caching
|
||||
= runState lowerBound
|
||||
. runReader lowerBound
|
||||
|
||||
@ -21,5 +21,5 @@ collectingTerms recur term = do
|
||||
v <$ TermEvaluator (gc (roots <> valueRoots v))
|
||||
|
||||
|
||||
providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a
|
||||
providingLiveSet :: (Effectful (m address value), Effects effects) => m address value (Reader (Live address) ': effects) a -> m address value effects a
|
||||
providingLiveSet = runReader lowerBound
|
||||
|
||||
@ -48,5 +48,5 @@ killingModules :: ( Foldable (Base term)
|
||||
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||
killingModules recur m = killAll (subterms (subterm (moduleBody m))) *> recur m
|
||||
|
||||
providingDeadSet :: TermEvaluator term address value (State (Dead term) ': effects) a -> TermEvaluator term address value effects (a, Dead term)
|
||||
providingDeadSet :: Effects effects => TermEvaluator term address value (State (Dead term) ': effects) a -> TermEvaluator term address value effects (Dead term, a)
|
||||
providingDeadSet = runState lowerBound
|
||||
|
||||
@ -71,7 +71,8 @@ graphingPackages recur m = packageInclusion (moduleVertex (moduleInfo m)) *> rec
|
||||
|
||||
-- | Add vertices to the graph for imported modules.
|
||||
graphingModules :: forall term address value effects a
|
||||
. ( Member (Modules address) effects
|
||||
. ( Effects effects
|
||||
, Member (Modules address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (State (Graph Vertex)) effects
|
||||
)
|
||||
@ -79,15 +80,16 @@ graphingModules :: forall term address value effects a
|
||||
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||
graphingModules recur m = do
|
||||
appendGraph (vertex (moduleVertex (moduleInfo m)))
|
||||
interpose @(Modules address) pure (\ m yield -> case m of
|
||||
Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
|
||||
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
|
||||
_ -> send m >>= yield)
|
||||
eavesdrop @(Modules address) (\ m -> case m of
|
||||
Load path -> moduleInclusion (moduleVertex (ModuleInfo path))
|
||||
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path))
|
||||
_ -> pure ())
|
||||
(recur m)
|
||||
|
||||
-- | Add vertices to the graph for imported modules.
|
||||
graphingModuleInfo :: forall term address value effects a
|
||||
. ( Member (Modules address) effects
|
||||
. ( Effects effects
|
||||
, Member (Modules address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (State (Graph ModuleInfo)) effects
|
||||
)
|
||||
@ -95,10 +97,10 @@ graphingModuleInfo :: forall term address value effects a
|
||||
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||
graphingModuleInfo recur m = do
|
||||
appendGraph (vertex (moduleInfo m))
|
||||
interpose @(Modules address) pure (\ eff yield -> case eff of
|
||||
Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex >> send eff >>= yield
|
||||
Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex >> send eff >>= yield
|
||||
_ -> send eff >>= yield)
|
||||
eavesdrop @(Modules address) (\ eff -> case eff of
|
||||
Load path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
|
||||
Lookup path -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex
|
||||
_ -> pure ())
|
||||
(recur m)
|
||||
|
||||
-- | Add an edge from the current package to the passed vertex.
|
||||
@ -139,5 +141,5 @@ appendGraph :: (Effectful m, Member (State (Graph v)) effects) => Graph v -> m e
|
||||
appendGraph = modify' . (<>)
|
||||
|
||||
|
||||
graphing :: Effectful m => m (State (Graph Vertex) ': effects) result -> m effects (result, Graph Vertex)
|
||||
graphing :: (Effectful m, Effects effects) => m (State (Graph Vertex) ': effects) result -> m effects (Graph Vertex, result)
|
||||
graphing = runState mempty
|
||||
|
||||
@ -27,5 +27,5 @@ tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace .
|
||||
trace :: Member (Writer (trace (Configuration term address (Cell address) value))) effects => trace (Configuration term address (Cell address) value) -> TermEvaluator term address value effects ()
|
||||
trace = tell
|
||||
|
||||
tracing :: Monoid (trace (Configuration term address (Cell address) value)) => TermEvaluator term address value (Writer (trace (Configuration term address (Cell address) value)) ': effects) a -> TermEvaluator term address value effects (a, trace (Configuration term address (Cell address) value))
|
||||
tracing :: (Monoid (trace (Configuration term address (Cell address) value)), Effects effects) => TermEvaluator term address value (Writer (trace (Configuration term address (Cell address) value)) ': effects) a -> TermEvaluator term address value effects (trace (Configuration term address (Cell address) value), a)
|
||||
tracing = runWriter
|
||||
|
||||
@ -48,10 +48,7 @@ bindAll = foldr ((>>) . uncurry bind) (pure ()) . Env.flatPairs
|
||||
|
||||
-- | Run an action in a new local scope.
|
||||
locally :: forall address value effects a . Member (Env address) effects => Evaluator address value effects a -> Evaluator address value effects a
|
||||
locally a = do
|
||||
send (Push @address)
|
||||
a' <- a
|
||||
a' <$ send (Pop @address)
|
||||
locally = send . Locally @address . lowerEff
|
||||
|
||||
close :: Member (Env address) effects => Set Name -> Evaluator address value effects (Environment address)
|
||||
close = send . Close
|
||||
@ -59,42 +56,46 @@ close = send . Close
|
||||
|
||||
-- Effects
|
||||
|
||||
data Env address return where
|
||||
Lookup :: Name -> Env address (Maybe address)
|
||||
Bind :: Name -> address -> Env address ()
|
||||
Close :: Set Name -> Env address (Environment address)
|
||||
Push :: Env address ()
|
||||
Pop :: Env address ()
|
||||
GetEnv :: Env address (Environment address)
|
||||
Export :: Name -> Name -> Maybe address -> Env address ()
|
||||
data Env address m return where
|
||||
Lookup :: Name -> Env address m (Maybe address)
|
||||
Bind :: Name -> address -> Env address m ()
|
||||
Close :: Set Name -> Env address m (Environment address)
|
||||
Locally :: m a -> Env address m a
|
||||
GetEnv :: Env address m (Environment address)
|
||||
Export :: Name -> Name -> Maybe address -> Env address m ()
|
||||
|
||||
handleEnv :: forall address effects value result
|
||||
. ( Member (State (Environment address)) effects
|
||||
, Member (State (Exports address)) effects
|
||||
)
|
||||
=> Env address result
|
||||
-> Evaluator address value effects result
|
||||
instance Effect (Env address) where
|
||||
handleState c dist (Request (Lookup name) k) = Request (Lookup name) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Bind name addr) k) = Request (Bind name addr) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Close names) k) = Request (Close names) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Locally action) k) = Request (Locally (dist (action <$ c))) (dist . fmap k)
|
||||
handleState c dist (Request GetEnv k) = Request GetEnv (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Export name alias addr) k) = Request (Export name alias addr) (dist . (<$ c) . k)
|
||||
|
||||
runEnv :: Effects effects
|
||||
=> Environment address
|
||||
-> Evaluator address value (Env address ': effects) a
|
||||
-> Evaluator address value effects (Environment address, a)
|
||||
runEnv initial = fmap (filterEnv . fmap (first Env.head)) . runState lowerBound . runState (Env.push initial) . reinterpret2 handleEnv
|
||||
where -- TODO: If the set of exports is empty because no exports have been
|
||||
-- defined, do we export all terms, or no terms? This behavior varies across
|
||||
-- languages. We need better semantics rather than doing it ad-hoc.
|
||||
filterEnv (ports, (binds, a))
|
||||
| Exports.null ports = (Env.newEnv binds, a)
|
||||
| otherwise = (Env.newEnv (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds), a)
|
||||
|
||||
handleEnv :: forall address value effects a . Effects effects => Env address (Eff (Env address ': effects)) a -> Evaluator address value (State (Environment address) ': State (Exports address) ': effects) a
|
||||
handleEnv = \case
|
||||
Lookup name -> Env.lookup name <$> get
|
||||
Bind name addr -> modify (Env.insert name addr)
|
||||
Close names -> Env.intersect names <$> get
|
||||
Push -> modify (Env.push @address)
|
||||
Pop -> modify (Env.pop @address)
|
||||
Locally action -> do
|
||||
modify' (Env.push @address)
|
||||
a <- reinterpret2 handleEnv (raiseEff action)
|
||||
a <$ modify' (Env.pop @address)
|
||||
GetEnv -> get
|
||||
Export name alias addr -> modify (Exports.insert name alias addr)
|
||||
|
||||
runEnv :: Environment address
|
||||
-> Evaluator address value (Env address ': effects) a
|
||||
-> Evaluator address value effects (a, Environment address)
|
||||
runEnv initial = fmap (uncurry filterEnv . first (fmap Env.head)) . runState lowerBound . runState (Env.push initial) . reinterpret2 handleEnv
|
||||
where -- TODO: If the set of exports is empty because no exports have been
|
||||
-- defined, do we export all terms, or no terms? This behavior varies across
|
||||
-- languages. We need better semantics rather than doing it ad-hoc.
|
||||
filterEnv (a, binds) ports
|
||||
| Exports.null ports = (a, Env.newEnv binds)
|
||||
| otherwise = (a, Env.newEnv (Exports.toBindings ports <> Env.aliasBindings (Exports.aliases ports) binds))
|
||||
|
||||
|
||||
-- | Errors involving the environment.
|
||||
data EnvironmentError address return where
|
||||
FreeVariable :: Name -> EnvironmentError address address
|
||||
@ -107,8 +108,8 @@ instance Eq1 (EnvironmentError address) where liftEq _ (FreeVariable n1) (FreeVa
|
||||
freeVariableError :: Member (Resumable (EnvironmentError address)) effects => Name -> Evaluator address value effects address
|
||||
freeVariableError = throwResumable . FreeVariable
|
||||
|
||||
runEnvironmentError :: Effectful (m address value) => m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects (Either (SomeExc (EnvironmentError address)) a)
|
||||
runEnvironmentError :: (Effectful (m address value), Effects effects) => m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects (Either (SomeExc (EnvironmentError address)) a)
|
||||
runEnvironmentError = runResumable
|
||||
|
||||
runEnvironmentErrorWith :: Effectful (m address value) => (forall resume . EnvironmentError address resume -> m address value effects resume) -> m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects a
|
||||
runEnvironmentErrorWith :: (Effectful (m address value), Effects effects) => (forall resume . EnvironmentError address resume -> m address value effects resume) -> m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects a
|
||||
runEnvironmentErrorWith = runResumableWith
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeOperators #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators #-}
|
||||
module Control.Abstract.Evaluator
|
||||
( Evaluator(..)
|
||||
-- * Effects
|
||||
@ -16,13 +16,14 @@ module Control.Abstract.Evaluator
|
||||
|
||||
import Control.Monad.Effect as X
|
||||
import Control.Monad.Effect.Fresh as X
|
||||
import Control.Monad.Effect.Internal
|
||||
import Control.Monad.Effect.Exception as X
|
||||
import qualified Control.Monad.Effect.Internal as Eff
|
||||
import Control.Monad.Effect.NonDet as X
|
||||
import Control.Monad.Effect.Reader as X
|
||||
import Control.Monad.Effect.Resumable as X
|
||||
import Control.Monad.Effect.State as X
|
||||
import Control.Monad.Effect.Trace as X
|
||||
import Prologue
|
||||
import Prologue hiding (MonadError(..))
|
||||
|
||||
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types.
|
||||
--
|
||||
@ -37,46 +38,39 @@ deriving instance Member NonDet effects => Alternative (Evaluator address value
|
||||
-- Effects
|
||||
|
||||
-- | An effect for explicitly returning out of a function/method body.
|
||||
data Return address resume where
|
||||
Return :: address -> Return address address
|
||||
newtype Return address = Return { unReturn :: address }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
deriving instance Eq address => Eq (Return address a)
|
||||
deriving instance Show address => Show (Return address a)
|
||||
|
||||
earlyReturn :: Member (Return address) effects
|
||||
earlyReturn :: Member (Exc (Return address)) effects
|
||||
=> address
|
||||
-> Evaluator address value effects address
|
||||
earlyReturn = send . Return
|
||||
earlyReturn = throwError . Return
|
||||
|
||||
catchReturn :: Member (Return address) effects => Evaluator address value effects a -> (forall x . Return address x -> Evaluator address value effects a) -> Evaluator address value effects a
|
||||
catchReturn action handler = interpose pure (\ ret _ -> handler ret) action
|
||||
catchReturn :: (Member (Exc (Return address)) effects, Effectful (m address value)) => m address value effects address -> m address value effects address
|
||||
catchReturn = Eff.raiseHandler (handleError (\ (Return addr) -> pure addr))
|
||||
|
||||
runReturn :: Effectful (m address value) => m address value (Return address ': effects) address -> m address value effects address
|
||||
runReturn = raiseHandler (relay pure (\ (Return value) _ -> pure value))
|
||||
runReturn :: (Effectful (m address value), Effects effects) => m address value (Exc (Return address) ': effects) address -> m address value effects address
|
||||
runReturn = Eff.raiseHandler (fmap (either unReturn id) . runError)
|
||||
|
||||
|
||||
-- | Effects for control flow around loops (breaking and continuing).
|
||||
data LoopControl address resume where
|
||||
Break :: address -> LoopControl address address
|
||||
Continue :: address -> LoopControl address address
|
||||
data LoopControl address
|
||||
= Break { unLoopControl :: address }
|
||||
| Continue { unLoopControl :: address }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
deriving instance Eq address => Eq (LoopControl address a)
|
||||
deriving instance Show address => Show (LoopControl address a)
|
||||
|
||||
throwBreak :: Member (LoopControl address) effects
|
||||
throwBreak :: Member (Exc (LoopControl address)) effects
|
||||
=> address
|
||||
-> Evaluator address value effects address
|
||||
throwBreak = send . Break
|
||||
throwBreak = throwError . Break
|
||||
|
||||
throwContinue :: Member (LoopControl address) effects
|
||||
throwContinue :: Member (Exc (LoopControl address)) effects
|
||||
=> address
|
||||
-> Evaluator address value effects address
|
||||
throwContinue = send . Continue
|
||||
throwContinue = throwError . Continue
|
||||
|
||||
catchLoopControl :: Member (LoopControl address) effects => Evaluator address value effects a -> (forall x . LoopControl address x -> Evaluator address value effects a) -> Evaluator address value effects a
|
||||
catchLoopControl action handler = interpose pure (\ control _ -> handler control) action
|
||||
catchLoopControl :: (Member (Exc (LoopControl address)) effects, Effectful (m address value)) => m address value effects a -> (LoopControl address -> m address value effects a) -> m address value effects a
|
||||
catchLoopControl = catchError
|
||||
|
||||
runLoopControl :: Effectful (m address value) => m address value (LoopControl address ': effects) address -> m address value effects address
|
||||
runLoopControl = raiseHandler (relay pure (\ eff _ -> case eff of
|
||||
Break value -> pure value
|
||||
Continue value -> pure value))
|
||||
runLoopControl :: (Effectful (m address value), Effects effects) => m address value (Exc (LoopControl address) ': effects) address -> m address value effects address
|
||||
runLoopControl = Eff.raiseHandler (fmap (either unLoopControl id) . runError)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
|
||||
module Control.Abstract.Heap
|
||||
( Heap
|
||||
, Configuration(..)
|
||||
@ -146,16 +146,17 @@ reachable roots heap = go mempty roots
|
||||
|
||||
-- Effects
|
||||
|
||||
sendAllocator :: Member (Allocator address value) effects => Allocator address value return -> Evaluator address value effects return
|
||||
sendAllocator :: Member (Allocator address value) effects => Allocator address value (Eff effects) return -> Evaluator address value effects return
|
||||
sendAllocator = send
|
||||
|
||||
data Allocator address value return where
|
||||
Alloc :: Name -> Allocator address value address
|
||||
Deref :: address -> Allocator address value value
|
||||
Assign :: address -> value -> Allocator address value ()
|
||||
GC :: Live address -> Allocator address value ()
|
||||
data Allocator address value (m :: * -> *) return where
|
||||
Alloc :: Name -> Allocator address value m address
|
||||
Deref :: address -> Allocator address value m value
|
||||
Assign :: address -> value -> Allocator address value m ()
|
||||
GC :: Live address -> Allocator address value m ()
|
||||
|
||||
runAllocator :: ( Addressable address effects
|
||||
, Effects effects
|
||||
, Foldable (Cell address)
|
||||
, Member (Resumable (AddressError address value)) effects
|
||||
, Member (State (Heap address (Cell address) value)) effects
|
||||
@ -170,6 +171,12 @@ runAllocator = interpret $ \ eff -> case eff of
|
||||
Assign addr value -> modifyHeap (heapInsert addr value)
|
||||
GC roots -> modifyHeap (heapRestrict <*> reachable roots)
|
||||
|
||||
instance Effect (Allocator address value) where
|
||||
handleState c dist (Request (Alloc name) k) = Request (Alloc name) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Deref addr) k) = Request (Deref addr) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Assign addr value) k) = Request (Assign addr value) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (GC roots) k) = Request (GC roots) (dist . (<$ c) . k)
|
||||
|
||||
|
||||
data AddressError address value resume where
|
||||
UnallocatedAddress :: address -> AddressError address value (Cell address value)
|
||||
@ -185,8 +192,8 @@ instance Eq address => Eq1 (AddressError address value) where
|
||||
liftEq _ _ _ = False
|
||||
|
||||
|
||||
runAddressError :: Effectful (m address value) => m address value (Resumable (AddressError address value) ': effects) a -> m address value effects (Either (SomeExc (AddressError address value)) a)
|
||||
runAddressError :: (Effectful (m address value), Effects effects) => m address value (Resumable (AddressError address value) ': effects) a -> m address value effects (Either (SomeExc (AddressError address value)) a)
|
||||
runAddressError = runResumable
|
||||
|
||||
runAddressErrorWith :: Effectful (m address value) => (forall resume . AddressError address value resume -> m address value effects resume) -> m address value (Resumable (AddressError address value) ': effects) a -> m address value effects a
|
||||
runAddressErrorWith :: (Effectful (m address value), Effects effects) => (forall resume . AddressError address value resume -> m address value effects resume) -> m address value (Resumable (AddressError address value) ': effects) a -> m address value effects a
|
||||
runAddressErrorWith = runResumableWith
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-}
|
||||
{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators #-}
|
||||
module Control.Abstract.Modules
|
||||
( lookupModule
|
||||
, resolve
|
||||
@ -9,7 +9,6 @@ module Control.Abstract.Modules
|
||||
, runModules
|
||||
, LoadError(..)
|
||||
, moduleNotFound
|
||||
, resumeLoadError
|
||||
, runLoadError
|
||||
, runLoadErrorWith
|
||||
, ResolutionError(..)
|
||||
@ -29,7 +28,7 @@ import Prologue
|
||||
import System.FilePath.Posix (takeDirectory)
|
||||
|
||||
-- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load.
|
||||
lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Maybe (address, Environment address))
|
||||
lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, address))
|
||||
lookupModule = sendModules . Lookup
|
||||
|
||||
-- | Resolve a list of module paths to a possible module table entry.
|
||||
@ -43,26 +42,33 @@ listModulesInDir = sendModules . List
|
||||
-- | 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) effects => ModulePath -> Evaluator address value effects (address, Environment address)
|
||||
require :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (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) effects => ModulePath -> Evaluator address value effects (address, Environment address)
|
||||
load :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Environment address, address)
|
||||
load path = sendModules (Load path)
|
||||
|
||||
|
||||
data Modules address return where
|
||||
Load :: ModulePath -> Modules address (address, Environment address)
|
||||
Lookup :: ModulePath -> Modules address (Maybe (address, Environment address))
|
||||
Resolve :: [FilePath] -> Modules address (Maybe ModulePath)
|
||||
List :: FilePath -> Modules address [ModulePath]
|
||||
data Modules address (m :: * -> *) return where
|
||||
Load :: ModulePath -> Modules address m (Environment address, address)
|
||||
Lookup :: ModulePath -> Modules address m (Maybe (Environment address, address))
|
||||
Resolve :: [FilePath] -> Modules address m (Maybe ModulePath)
|
||||
List :: FilePath -> Modules address m [ModulePath]
|
||||
|
||||
sendModules :: Member (Modules address) effects => Modules address return -> Evaluator address value effects return
|
||||
instance Effect (Modules address) where
|
||||
handleState c dist (Request (Load path) k) = Request (Load path) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Lookup path) k) = Request (Lookup path) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Resolve paths) k) = Request (Resolve paths) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (List path) k) = Request (List path) (dist . (<$ c) . k)
|
||||
|
||||
sendModules :: Member (Modules address) effects => Modules address (Eff effects) return -> Evaluator address value effects return
|
||||
sendModules = send
|
||||
|
||||
runModules :: ( Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects -- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
|
||||
runModules :: ( Effects effects
|
||||
, Member (Reader (ModuleTable (NonEmpty (Module (Environment address, address))))) effects
|
||||
, Member (Resumable (LoadError address)) effects
|
||||
)
|
||||
=> Set ModulePath
|
||||
@ -74,19 +80,19 @@ runModules paths = interpret $ \case
|
||||
Resolve names -> pure (find (`Set.member` paths) names)
|
||||
List dir -> pure (filter ((dir ==) . takeDirectory) (toList paths))
|
||||
|
||||
askModuleTable :: Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module (address, Environment address))))
|
||||
askModuleTable = get
|
||||
askModuleTable :: Member (Reader (ModuleTable (NonEmpty (Module (Environment address, address))))) effects => Evaluator address value effects (ModuleTable (NonEmpty (Module (Environment address, address))))
|
||||
askModuleTable = ask
|
||||
|
||||
|
||||
newtype Merging address = Merging { runMerging :: (address, Environment address) }
|
||||
newtype Merging address = Merging { runMerging :: (Environment address, address) }
|
||||
|
||||
instance Semigroup (Merging address) where
|
||||
Merging (_, env1) <> Merging (addr, env2) = Merging (addr, mergeEnvs env1 env2)
|
||||
Merging (env1, _) <> Merging (env2, addr) = Merging (mergeEnvs env1 env2, addr)
|
||||
|
||||
|
||||
-- | 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 resume where
|
||||
ModuleNotFound :: ModulePath -> LoadError address (address, Environment address)
|
||||
ModuleNotFound :: ModulePath -> LoadError address (Environment address, address)
|
||||
|
||||
deriving instance Eq (LoadError address resume)
|
||||
deriving instance Show (LoadError address resume)
|
||||
@ -95,16 +101,13 @@ instance Show1 (LoadError address) where
|
||||
instance Eq1 (LoadError address) where
|
||||
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
|
||||
|
||||
moduleNotFound :: Member (Resumable (LoadError address)) effects => ModulePath -> Evaluator address value effects (address, Environment address)
|
||||
moduleNotFound :: Member (Resumable (LoadError address)) effects => ModulePath -> Evaluator address value effects (Environment address, address)
|
||||
moduleNotFound = throwResumable . ModuleNotFound
|
||||
|
||||
resumeLoadError :: Member (Resumable (LoadError address)) effects => Evaluator address value effects a -> (forall resume . LoadError address resume -> Evaluator address value effects resume) -> Evaluator address value effects a
|
||||
resumeLoadError = catchResumable
|
||||
|
||||
runLoadError :: Effectful (m address value) => m address value (Resumable (LoadError address) ': effects) a -> m address value effects (Either (SomeExc (LoadError address)) a)
|
||||
runLoadError :: (Effectful (m address value), Effects effects) => m address value (Resumable (LoadError address) ': effects) a -> m address value effects (Either (SomeExc (LoadError address)) a)
|
||||
runLoadError = runResumable
|
||||
|
||||
runLoadErrorWith :: Effectful (m address value) => (forall resume . LoadError address resume -> m address value effects resume) -> m address value (Resumable (LoadError address) ': effects) a -> m address value effects a
|
||||
runLoadErrorWith :: (Effectful (m address value), Effects effects) => (forall resume . LoadError address resume -> m address value effects resume) -> m address value (Resumable (LoadError address) ': effects) a -> m address value effects a
|
||||
runLoadErrorWith = runResumableWith
|
||||
|
||||
|
||||
@ -125,8 +128,8 @@ instance Eq1 ResolutionError where
|
||||
liftEq _ (GoImportError a) (GoImportError b) = a == b
|
||||
liftEq _ _ _ = False
|
||||
|
||||
runResolutionError :: Effectful m => m (Resumable ResolutionError ': effects) a -> m effects (Either (SomeExc ResolutionError) a)
|
||||
runResolutionError :: (Effectful m, Effects effects) => m (Resumable ResolutionError ': effects) a -> m effects (Either (SomeExc ResolutionError) a)
|
||||
runResolutionError = runResumable
|
||||
|
||||
runResolutionErrorWith :: Effectful m => (forall resume . ResolutionError resume -> m effects resume) -> m (Resumable ResolutionError ': effects) a -> m effects a
|
||||
runResolutionErrorWith :: (Effectful m, Effects effects) => (forall resume . ResolutionError resume -> m effects resume) -> m (Resumable ResolutionError ': effects) a -> m effects a
|
||||
runResolutionErrorWith = runResumableWith
|
||||
|
||||
@ -48,7 +48,8 @@ class Show1 constr => Evaluatable constr where
|
||||
, FreeVariables term
|
||||
, Member (Allocator address value) effects
|
||||
, Member (Env address) effects
|
||||
, Member (LoopControl address) effects
|
||||
, Member (Exc (LoopControl address)) effects
|
||||
, Member (Exc (Return address)) effects
|
||||
, Member (Modules address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
@ -57,7 +58,6 @@ class Show1 constr => Evaluatable constr where
|
||||
, Member (Resumable EvalError) effects
|
||||
, Member (Resumable ResolutionError) effects
|
||||
, Member (Resumable (Unspecialized value)) effects
|
||||
, Member (Return address) effects
|
||||
, Member Trace effects
|
||||
)
|
||||
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef address))
|
||||
@ -67,13 +67,14 @@ class Show1 constr => Evaluatable constr where
|
||||
evaluate :: ( AbstractValue address value inner
|
||||
, Addressable address (Reader ModuleInfo ': effects)
|
||||
, Declarations term
|
||||
, Effects effects
|
||||
, Evaluatable (Base term)
|
||||
, Foldable (Cell address)
|
||||
, FreeVariables term
|
||||
, HasPrelude lang
|
||||
, Member Fresh effects
|
||||
, Member (Modules address) effects
|
||||
, Member (State (ModuleTable (NonEmpty (Module (address, Environment address))))) effects
|
||||
, Member (Reader (ModuleTable (NonEmpty (Module (Environment address, address))))) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, Member (Reader Span) effects
|
||||
, Member (Resumable (AddressError address value)) effects
|
||||
@ -86,27 +87,26 @@ evaluate :: ( AbstractValue address value inner
|
||||
, Recursive term
|
||||
, Reducer value (Cell address value)
|
||||
, ValueRoots address value
|
||||
, inner ~ (LoopControl address ': Return address ': Env address ': Allocator address value ': Reader ModuleInfo ': effects)
|
||||
, inner ~ (Exc (LoopControl address) ': Exc (Return address) ': Env address ': Allocator address value ': Reader ModuleInfo ': effects)
|
||||
)
|
||||
=> proxy lang
|
||||
-> (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)))
|
||||
-> [Module term]
|
||||
-> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (address, Environment address))))
|
||||
-> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (Environment address, address))))
|
||||
evaluate lang analyzeModule analyzeTerm modules = do
|
||||
(_, preludeEnv) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack $ do
|
||||
(preludeEnv, _) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack $ do
|
||||
defineBuiltins
|
||||
definePrelude lang
|
||||
box unit
|
||||
foldr (run preludeEnv) get modules
|
||||
foldr (run preludeEnv) ask modules
|
||||
where run preludeEnv m rest = do
|
||||
evaluated <- coerce
|
||||
(runInModule preludeEnv (moduleInfo m))
|
||||
(analyzeModule (subtermRef . moduleBody)
|
||||
(evalTerm <$> m))
|
||||
-- FIXME: this should be some sort of Monoidal insert à la the Heap to accommodate multiple Go files being part of the same module.
|
||||
modify' (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| []))
|
||||
rest
|
||||
local (ModuleTable.insert (modulePath (moduleInfo m)) ((evaluated <$ m) :| [])) rest
|
||||
|
||||
evalTerm term = Subterm term (foldSubterms (analyzeTerm (TermEvaluator . eval . fmap (second runTermEvaluator))) term >>= TermEvaluator . address)
|
||||
|
||||
@ -201,10 +201,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
|
||||
|
||||
|
||||
@ -220,10 +220,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
|
||||
|
||||
|
||||
|
||||
@ -79,10 +79,10 @@ instance Ord1 TypeError where
|
||||
|
||||
instance Show1 TypeError where liftShowsPrec _ _ = showsPrec
|
||||
|
||||
runTypeError :: Effectful m => m (Resumable TypeError ': effects) a -> m effects (Either (SomeExc TypeError) a)
|
||||
runTypeError :: (Effectful m, Effects effects) => m (Resumable TypeError ': effects) a -> m effects (Either (SomeExc TypeError) a)
|
||||
runTypeError = runResumable
|
||||
|
||||
runTypeErrorWith :: Effectful m => (forall resume . TypeError resume -> m effects resume) -> m (Resumable TypeError ': effects) a -> m effects a
|
||||
runTypeErrorWith :: (Effectful m, Effects effects) => (forall resume . TypeError resume -> m effects resume) -> m (Resumable TypeError ': effects) a -> m effects a
|
||||
runTypeErrorWith = runResumableWith
|
||||
|
||||
runTypeMap :: ( Effectful m
|
||||
@ -230,7 +230,7 @@ instance ( Member (Allocator address Type) effects
|
||||
, Member Fresh effects
|
||||
, Member (Resumable TypeError) effects
|
||||
, Member (State TypeMap) effects
|
||||
, Member (Return address) effects
|
||||
, Member (Exc (Return address)) effects
|
||||
)
|
||||
=> AbstractFunction address Type effects where
|
||||
closure names _ body = do
|
||||
@ -239,7 +239,7 @@ instance ( Member (Allocator address Type) effects
|
||||
tvar <- Var <$> fresh
|
||||
assign addr tvar
|
||||
bimap (Env.insert name addr) (tvar :) <$> rest) (pure (lowerBound, [])) names
|
||||
(zeroOrMoreProduct tvars :->) <$> (deref =<< locally (bindAll env *> body `catchReturn` \ (Return ptr) -> pure ptr))
|
||||
(zeroOrMoreProduct tvars :->) <$> (deref =<< locally (catchReturn (bindAll env *> body)))
|
||||
|
||||
call op params = do
|
||||
tvar <- fresh
|
||||
@ -258,7 +258,7 @@ instance ( Member (Allocator address Type) effects
|
||||
, Member NonDet effects
|
||||
, Member (Resumable TypeError) effects
|
||||
, Member (State TypeMap) effects
|
||||
, Member (Return address) effects
|
||||
, Member (Exc (Return address)) effects
|
||||
)
|
||||
=> AbstractValue address Type effects where
|
||||
array fields = do
|
||||
|
||||
@ -60,7 +60,7 @@ instance ( Coercible body (Eff effects)
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, Member (Resumable (ValueError address body)) effects
|
||||
, Member (Return address) effects
|
||||
, Member (Exc (Return address)) effects
|
||||
, Show address
|
||||
)
|
||||
=> AbstractFunction address (Value address body) effects where
|
||||
@ -79,7 +79,7 @@ instance ( Coercible body (Eff effects)
|
||||
bindings <- foldr (\ (name, param) rest -> do
|
||||
addr <- param
|
||||
Env.insert name addr <$> rest) (pure env) (zip names params)
|
||||
locally (bindAll bindings *> raiseEff (coerce body) `catchReturn` \ (Return ptr) -> pure ptr)
|
||||
locally (catchReturn (bindAll bindings *> raiseEff (coerce body)))
|
||||
_ -> box =<< throwValueError (CallError op)
|
||||
|
||||
|
||||
@ -102,12 +102,12 @@ instance Show address => AbstractIntro (Value address body) where
|
||||
instance ( Coercible body (Eff effects)
|
||||
, Member (Allocator address (Value address body)) effects
|
||||
, Member (Env address) effects
|
||||
, Member (Exc (LoopControl address)) effects
|
||||
, Member (Exc (Return address)) effects
|
||||
, Member Fresh effects
|
||||
, Member (LoopControl address) effects
|
||||
, Member (Reader ModuleInfo) effects
|
||||
, Member (Reader PackageInfo) effects
|
||||
, Member (Resumable (ValueError address body)) effects
|
||||
, Member (Return address) effects
|
||||
, Show address
|
||||
)
|
||||
=> AbstractValue address (Value address body) effects where
|
||||
@ -260,8 +260,8 @@ instance Show address => Show1 (ValueError address body) where
|
||||
throwValueError :: Member (Resumable (ValueError address body)) effects => ValueError address body resume -> Evaluator address (Value address body) effects resume
|
||||
throwValueError = throwResumable
|
||||
|
||||
runValueError :: Effectful (m address (Value address body)) => m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects (Either (SomeExc (ValueError address body)) a)
|
||||
runValueError :: (Effectful (m address (Value address body)), Effects effects) => m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects (Either (SomeExc (ValueError address body)) a)
|
||||
runValueError = runResumable
|
||||
|
||||
runValueErrorWith :: Effectful (m address (Value address body)) => (forall resume . ValueError address body resume -> m address (Value address body) effects resume) -> m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects a
|
||||
runValueErrorWith :: (Effectful (m address (Value address body)), Effects effects) => (forall resume . ValueError address body resume -> m address (Value address body) effects resume) -> m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects a
|
||||
runValueErrorWith = runResumableWith
|
||||
|
||||
@ -54,7 +54,7 @@ topologicalSort :: forall v . Ord v => Graph v -> [v]
|
||||
topologicalSort = go . toAdjacencyMap . G.transpose . unGraph
|
||||
where go :: A.AdjacencyMap v -> [v]
|
||||
go graph
|
||||
= visitedOrder . snd
|
||||
= visitedOrder . fst
|
||||
. run
|
||||
. runState (Visited lowerBound [])
|
||||
. traverse_ visit
|
||||
|
||||
@ -124,7 +124,7 @@ tagGraph :: forall a . (Eq a, Hashable a) => Graph a -> Graph (a, Tag)
|
||||
tagGraph = unwrap . traverse go where
|
||||
|
||||
unwrap :: Eff '[Fresh, State (HashMap a Tag)] (Graph (a, Tag)) -> Graph (a, Tag)
|
||||
unwrap = run . fmap fst . runState HashMap.empty . runFresh 1
|
||||
unwrap = run . fmap snd . runState HashMap.empty . runFresh 1
|
||||
|
||||
go :: a -> Eff '[Fresh, State (HashMap a Tag)] (a, Tag)
|
||||
go v = gets (HashMap.lookup v) >>= \case
|
||||
|
||||
@ -58,7 +58,7 @@ emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
|
||||
|
||||
-- | Catch assignment errors into an error term.
|
||||
handleError :: (HasCallStack, Error :< syntaxes, Enum grammar, Eq1 ast, Ix grammar, Show grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location)) -> Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location))
|
||||
handleError = flip catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
|
||||
handleError = flip Assignment.catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
|
||||
|
||||
-- | Catch parse errors into an error term.
|
||||
parseError :: (HasCallStack, Error :< syntaxes, Bounded grammar, Enum grammar, Ix grammar, Apply Foldable syntaxes) => Assignment.Assignment ast grammar (Term (Sum syntaxes) (Record Location))
|
||||
|
||||
@ -66,7 +66,7 @@ instance Evaluatable Import where
|
||||
paths <- resolveGoImport importPath
|
||||
for_ paths $ \path -> do
|
||||
traceResolve (unPath importPath) path
|
||||
importedEnv <- snd <$> require path
|
||||
importedEnv <- fst <$> require path
|
||||
bindAll importedEnv
|
||||
rvalBox unit
|
||||
|
||||
@ -88,7 +88,7 @@ instance Evaluatable QualifiedImport where
|
||||
void . letrec' alias $ \addr -> do
|
||||
for_ paths $ \p -> do
|
||||
traceResolve (unPath importPath) p
|
||||
importedEnv <- snd <$> require p
|
||||
importedEnv <- fst <$> require p
|
||||
bindAll importedEnv
|
||||
makeNamespace alias addr Nothing
|
||||
rvalBox unit
|
||||
|
||||
@ -632,7 +632,7 @@ module' = makeTerm
|
||||
<*> moduleExports
|
||||
<*> term (where' <|> expressions <|> emptyTerm))
|
||||
where
|
||||
moduleExports = (symbol ModuleExports *> children (manyTerm export))
|
||||
moduleExports = symbol ModuleExports *> children (manyTerm export)
|
||||
<|> pure []
|
||||
|
||||
moduleExport :: Assignment Term
|
||||
|
||||
@ -55,13 +55,13 @@ include :: ( AbstractValue address value effects
|
||||
, Member Trace effects
|
||||
)
|
||||
=> Subterm term (Evaluator address value effects (ValueRef address))
|
||||
-> (ModulePath -> Evaluator address value effects (address, Environment address))
|
||||
-> (ModulePath -> Evaluator address value effects (Environment address, address))
|
||||
-> Evaluator address value effects (ValueRef address)
|
||||
include pathTerm f = do
|
||||
name <- subtermValue pathTerm >>= asString
|
||||
path <- resolvePHPName name
|
||||
traceResolve name path
|
||||
(v, importedEnv) <- f path
|
||||
(importedEnv, v) <- f path
|
||||
bindAll importedEnv
|
||||
pure (Rval v)
|
||||
|
||||
|
||||
@ -113,7 +113,7 @@ instance Evaluatable Import where
|
||||
|
||||
-- Last module path is the one we want to import
|
||||
let path = NonEmpty.last modulePaths
|
||||
importedEnv <- snd <$> require path
|
||||
importedEnv <- fst <$> require path
|
||||
bindAll (select importedEnv)
|
||||
rvalBox unit
|
||||
where
|
||||
@ -130,7 +130,7 @@ evalQualifiedImport :: ( AbstractValue address value effects
|
||||
)
|
||||
=> Name -> ModulePath -> Evaluator address value effects value
|
||||
evalQualifiedImport name path = letrec' name $ \addr -> do
|
||||
importedEnv <- snd <$> require path
|
||||
importedEnv <- fst <$> require path
|
||||
bindAll importedEnv
|
||||
unit <$ makeNamespace name addr Nothing
|
||||
|
||||
@ -174,7 +174,7 @@ instance Evaluatable QualifiedAliasedImport where
|
||||
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
|
||||
rvalBox =<< letrec' alias (\addr -> do
|
||||
let path = NonEmpty.last modulePaths
|
||||
importedEnv <- snd <$> require path
|
||||
importedEnv <- fst <$> require path
|
||||
bindAll importedEnv
|
||||
unit <$ makeNamespace alias addr Nothing)
|
||||
|
||||
|
||||
@ -69,7 +69,7 @@ instance Evaluatable Require where
|
||||
name <- subtermValue x >>= asString
|
||||
path <- resolveRubyName name
|
||||
traceResolve name path
|
||||
(v, importedEnv) <- doRequire path
|
||||
(importedEnv, v) <- doRequire path
|
||||
bindAll importedEnv
|
||||
rvalBox v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
|
||||
|
||||
@ -77,12 +77,12 @@ doRequire :: ( AbstractValue address value effects
|
||||
, Member (Modules address) effects
|
||||
)
|
||||
=> M.ModulePath
|
||||
-> Evaluator address value effects (value, Environment address)
|
||||
-> Evaluator address value effects (Environment address, value)
|
||||
doRequire path = do
|
||||
result <- lookupModule path
|
||||
case result of
|
||||
Nothing -> (,) (boolean True) . snd <$> load path
|
||||
Just (_, env) -> pure (boolean False, env)
|
||||
Nothing -> flip (,) (boolean True) . fst <$> load path
|
||||
Just (env, _) -> pure (env, boolean False)
|
||||
|
||||
|
||||
data Load a = Load { loadPath :: a, loadWrap :: Maybe a }
|
||||
@ -113,7 +113,7 @@ doLoad :: ( AbstractValue address value effects
|
||||
doLoad path shouldWrap = do
|
||||
path' <- resolveRubyPath path
|
||||
traceResolve path path'
|
||||
importedEnv <- snd <$> load path'
|
||||
importedEnv <- fst <$> load path'
|
||||
unless shouldWrap $ bindAll importedEnv
|
||||
pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load
|
||||
|
||||
|
||||
@ -158,7 +158,7 @@ evalRequire :: ( AbstractValue address value effects
|
||||
-> Name
|
||||
-> Evaluator address value effects value
|
||||
evalRequire modulePath alias = letrec' alias $ \addr -> do
|
||||
importedEnv <- snd <$> require modulePath
|
||||
importedEnv <- fst <$> require modulePath
|
||||
bindAll importedEnv
|
||||
unit <$ makeNamespace alias addr Nothing
|
||||
|
||||
@ -173,7 +173,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Evaluatable Import where
|
||||
eval (Import symbols importPath) = do
|
||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||
importedEnv <- snd <$> require modulePath
|
||||
importedEnv <- fst <$> require modulePath
|
||||
bindAll (renamed importedEnv)
|
||||
rvalBox unit
|
||||
where
|
||||
@ -254,7 +254,7 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Evaluatable QualifiedExportFrom where
|
||||
eval (QualifiedExportFrom importPath exportSymbols) = do
|
||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||
importedEnv <- snd <$> require modulePath
|
||||
importedEnv <- fst <$> require modulePath
|
||||
-- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
|
||||
for_ exportSymbols $ \Alias{..} -> do
|
||||
let address = Env.lookup aliasValue importedEnv
|
||||
|
||||
@ -58,7 +58,7 @@ runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $
|
||||
|
||||
-- | Parse 'Source' with the given 'TS.Language' and return its AST.
|
||||
-- Returns Nothing if the operation timed out.
|
||||
parseToAST :: (Bounded grammar, Enum grammar, Member IO effects, Member Trace effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
|
||||
parseToAST :: (Bounded grammar, Enum grammar, Member (Lift IO) effects, Member Trace effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
|
||||
parseToAST (Milliseconds s) language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
|
||||
let parserTimeout = s * 1000
|
||||
|
||||
|
||||
@ -25,7 +25,7 @@ astParseBlob blob@Blob{..}
|
||||
data ASTFormat = SExpression | JSON | Show
|
||||
deriving (Show)
|
||||
|
||||
runASTParse :: (Member (Distribute WrappedTask) effects, Member Task effects) => ASTFormat -> [Blob] -> Eff effects F.Builder
|
||||
runASTParse SExpression = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow))))
|
||||
runASTParse Show = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize F.Show)))
|
||||
runASTParse JSON = distributeFoldMap (\ blob -> WrapTask (astParseBlob blob >>= withSomeAST (render (renderJSONAST blob)))) >=> serialize F.JSON
|
||||
runASTParse :: (Member Distribute effects, Member (Exc SomeException) effects, Member Task effects) => ASTFormat -> [Blob] -> Eff effects F.Builder
|
||||
runASTParse SExpression = distributeFoldMap (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow)))
|
||||
runASTParse Show = distributeFoldMap (astParseBlob >=> withSomeAST (serialize F.Show))
|
||||
runASTParse JSON = distributeFoldMap (\ blob -> astParseBlob blob >>= withSomeAST (render (renderJSONAST blob))) >=> serialize F.JSON
|
||||
|
||||
@ -19,7 +19,7 @@ import Semantic.Telemetry as Stat
|
||||
import Semantic.Task as Task
|
||||
import Serializing.Format
|
||||
|
||||
runDiff :: (Member (Distribute WrappedTask) effs, Member Task effs) => DiffRenderer output -> [BlobPair] -> Eff effs Builder
|
||||
runDiff :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => DiffRenderer output -> [BlobPair] -> Eff effs Builder
|
||||
runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
|
||||
runDiff JSONDiffRenderer = withParsedBlobPairs (const pure) (render . renderJSONDiff) >=> serialize JSON
|
||||
runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName)))
|
||||
@ -32,28 +32,28 @@ data SomeTermPair typeclasses ann where
|
||||
withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
|
||||
withSomeTermPair with (SomeTermPair terms) = with terms
|
||||
|
||||
diffBlobTOCPairs :: Member (Distribute WrappedTask) effs => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary])
|
||||
diffBlobTOCPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary])
|
||||
diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderRPCToCDiff)
|
||||
|
||||
type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
|
||||
|
||||
withParsedBlobPairs :: (Member (Distribute WrappedTask) effs, Monoid output)
|
||||
=> (forall syntax . CanDiff syntax => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
|
||||
-> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
|
||||
withParsedBlobPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs, Monoid output)
|
||||
=> (forall syntax . CanDiff syntax => Blob -> Term syntax (Record Location) -> Eff effs (Term syntax (Record fields)))
|
||||
-> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (Record fields) (Record fields) -> Eff effs output)
|
||||
-> [BlobPair]
|
||||
-> Eff effs output
|
||||
withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)))
|
||||
where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member IO effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields))
|
||||
withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs))
|
||||
where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields))
|
||||
diffTerms blobs terms = time "diff" languageTag $ do
|
||||
diff <- diff (runJoin terms)
|
||||
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
|
||||
where languageTag = languageTagForBlobPair blobs
|
||||
|
||||
withParsedBlobPair :: (Member (Distribute WrappedTask) effs, Member (Exc SomeException) effs)
|
||||
=> (forall syntax . (CanDiff syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
|
||||
withParsedBlobPair :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs)
|
||||
=> (forall syntax . (CanDiff syntax) => Blob -> Term syntax (Record Location) -> Eff effs (Term syntax (Record fields)))
|
||||
-> BlobPair
|
||||
-> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (Record fields))
|
||||
withParsedBlobPair decorate blobs
|
||||
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs)
|
||||
= SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob))
|
||||
= SomeTermPair <$> distributeFor blobs (\ blob -> parse parser blob >>= decorate blob)
|
||||
| otherwise = noLanguageForBlob (pathForBlobPair blobs)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Semantic.Distribute
|
||||
( distribute
|
||||
, distributeFor
|
||||
@ -8,37 +8,37 @@ module Semantic.Distribute
|
||||
) where
|
||||
|
||||
import qualified Control.Concurrent.Async as Async
|
||||
import Control.Monad.Effect
|
||||
import Control.Monad.Effect.Exception
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Parallel.Strategies
|
||||
import Control.Monad.Effect
|
||||
import Control.Monad.IO.Class
|
||||
import Prologue hiding (MonadError (..))
|
||||
|
||||
-- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.
|
||||
--
|
||||
-- This is a concurrent analogue of 'sequenceA'.
|
||||
distribute :: (Member (Distribute task) effs, Traversable t) => t (task output) -> Eff effs (t output)
|
||||
distribute = send . Distribute
|
||||
distribute :: (Member Distribute effs, Traversable t) => t (Eff effs output) -> Eff effs (t output)
|
||||
distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . Distribute)
|
||||
|
||||
-- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results.
|
||||
--
|
||||
-- This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped).
|
||||
distributeFor :: (Member (Distribute task) effs, Traversable t) => t a -> (a -> task output) -> Eff effs (t output)
|
||||
distributeFor :: (Member Distribute effs, Traversable t) => t a -> (a -> Eff effs output) -> Eff effs (t output)
|
||||
distributeFor inputs toTask = distribute (fmap toTask inputs)
|
||||
|
||||
-- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value.
|
||||
--
|
||||
-- This is a concurrent analogue of 'foldMap'.
|
||||
distributeFoldMap :: (Member (Distribute task) effs, Monoid output, Traversable t) => (a -> task output) -> t a -> Eff effs output
|
||||
distributeFoldMap :: (Member Distribute effs, Monoid output, Traversable t) => (a -> Eff effs output) -> t a -> Eff effs output
|
||||
distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
|
||||
|
||||
|
||||
-- | Distribute effects run tasks concurrently.
|
||||
data Distribute task output where
|
||||
Distribute :: Traversable t => t (task output) -> Distribute task (t output)
|
||||
newtype Distribute task output = Distribute (task output)
|
||||
|
||||
instance Effect Distribute where
|
||||
handleState c dist (Request (Distribute task) k) = Request (Distribute (dist (task <$ c))) (dist . fmap k)
|
||||
|
||||
|
||||
-- | Evaluate a 'Distribute' effect concurrently.
|
||||
runDistribute :: (Member (Exc SomeException) effs, Member IO effs) => (forall output . task output -> IO (Either SomeException output)) -> Eff (Distribute task ': effs) a -> Eff effs a
|
||||
runDistribute action = interpret (\ (Distribute tasks) ->
|
||||
liftIO (Async.mapConcurrently action tasks) >>= either throwError pure . sequenceA . withStrategy (parTraversable (parTraversable rseq)))
|
||||
runDistribute :: Eff '[Distribute, Lift IO] a -> Eff '[Lift IO] a
|
||||
runDistribute = interpret (\ (Distribute task) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistribute task)))))
|
||||
|
||||
@ -43,7 +43,7 @@ data GraphType = ImportGraph | CallGraph
|
||||
|
||||
type AnalysisClasses = '[ Declarations1, Eq1, Evaluatable, FreeVariables1, Functor, Ord1, Show1 ]
|
||||
|
||||
runGraph :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Task effs, Member Trace effs)
|
||||
runGraph :: (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs)
|
||||
=> GraphType
|
||||
-> Bool
|
||||
-> Project
|
||||
@ -58,7 +58,7 @@ runGraph CallGraph includePackages project
|
||||
modules <- runImportGraph lang package
|
||||
let analyzeTerm = withTermSpans . graphingTerms
|
||||
analyzeModule = (if includePackages then graphingPackages else id) . graphingModules
|
||||
extractGraph (((_, graph), _), _) = simplify graph
|
||||
extractGraph (_, (_, (graph, _))) = simplify graph
|
||||
runGraphAnalysis
|
||||
= run
|
||||
. runState lowerBound
|
||||
@ -75,21 +75,19 @@ runGraph CallGraph includePackages project
|
||||
. graphing
|
||||
. runReader (packageInfo package)
|
||||
. runReader lowerBound
|
||||
. fmap fst
|
||||
. runState lowerBound
|
||||
. runReader lowerBound
|
||||
. raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
|
||||
extractGraph <$> analyze runGraphAnalysis (evaluate lang analyzeModule analyzeTerm (topologicalSort modules))
|
||||
|
||||
-- | The full list of effects in flight during the evaluation of terms. This, and other @newtype@s like it, are necessary to type 'Value', since the bodies of closures embed evaluators. This would otherwise require cycles in the effect list (i.e. references to @effects@ within @effects@ itself), which the typechecker forbids.
|
||||
newtype GraphEff address a = GraphEff
|
||||
{ runGraphEff :: Eff '[ LoopControl address
|
||||
, Return address
|
||||
{ runGraphEff :: Eff '[ Exc (LoopControl address)
|
||||
, Exc (Return address)
|
||||
, Env address
|
||||
, Allocator address (Value address (GraphEff address))
|
||||
, Reader ModuleInfo
|
||||
, Modules address
|
||||
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
|
||||
, State (ModuleTable (NonEmpty (Module (address, Environment address))))
|
||||
, Reader (ModuleTable (NonEmpty (Module (Environment address, address))))
|
||||
, Reader Span
|
||||
, Reader PackageInfo
|
||||
, State (Graph Vertex)
|
||||
@ -123,7 +121,7 @@ runImportGraph lang (package :: Package term)
|
||||
| [m :| []] <- toList (packageModules package) = vertex m <$ trace ("single module, skipping import graph computation for " <> modulePath (moduleInfo m))
|
||||
| otherwise =
|
||||
let analyzeModule = graphingModuleInfo
|
||||
extractGraph (((_, graph), _), _) = do
|
||||
extractGraph (_, (_, (graph, _))) = do
|
||||
info <- graph
|
||||
maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package))
|
||||
runImportGraphAnalysis
|
||||
@ -139,8 +137,7 @@ runImportGraph lang (package :: Package term)
|
||||
. resumingAddressError
|
||||
. resumingValueError
|
||||
. runState lowerBound
|
||||
. fmap fst
|
||||
. runState lowerBound
|
||||
. runReader lowerBound
|
||||
. runModules (ModuleTable.modulePaths (packageModules package))
|
||||
. runTermEvaluator @_ @_ @(Value (Hole Precise) (ImportGraphEff term (Hole Precise)))
|
||||
. runReader (packageInfo package)
|
||||
@ -148,16 +145,15 @@ runImportGraph lang (package :: Package term)
|
||||
in extractGraph <$> analyze runImportGraphAnalysis (evaluate @_ @_ @_ @_ @term lang analyzeModule id (ModuleTable.toPairs (packageModules package) >>= toList . snd))
|
||||
|
||||
newtype ImportGraphEff term address a = ImportGraphEff
|
||||
{ runImportGraphEff :: Eff '[ LoopControl address
|
||||
, Return address
|
||||
{ runImportGraphEff :: Eff '[ Exc (LoopControl address)
|
||||
, Exc (Return address)
|
||||
, Env address
|
||||
, Allocator address (Value address (ImportGraphEff term address))
|
||||
, Reader ModuleInfo
|
||||
, Reader Span
|
||||
, Reader PackageInfo
|
||||
, Modules address
|
||||
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
|
||||
, State (ModuleTable (NonEmpty (Module (address, Environment address))))
|
||||
, Reader (ModuleTable (NonEmpty (Module (Environment address, address))))
|
||||
, State (Graph ModuleInfo)
|
||||
, Resumable (ValueError address (ImportGraphEff term address))
|
||||
, Resumable (AddressError address (Value address (ImportGraphEff term address)))
|
||||
@ -174,7 +170,7 @@ newtype ImportGraphEff term address a = ImportGraphEff
|
||||
|
||||
|
||||
-- | Parse a list of files into a 'Package'.
|
||||
parsePackage :: (Member (Distribute WrappedTask) effs, Member Resolution effs, Member Trace effs)
|
||||
parsePackage :: (Member Distribute effs, Member (Exc SomeException) effs, Member Resolution effs, Member Task effs, Member Trace effs)
|
||||
=> Parser term -- ^ A parser.
|
||||
-> Project -- ^ Project to parse into a package.
|
||||
-> Eff effs (Package term)
|
||||
@ -188,8 +184,8 @@ parsePackage parser project@Project{..} = do
|
||||
n = name (projectName project)
|
||||
|
||||
-- | Parse all files in a project into 'Module's.
|
||||
parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Project -> Eff effs [Module term]
|
||||
parseModules parser p@Project{..} = distributeFor (projectFiles p) (WrapTask . parseModule p parser)
|
||||
parseModules :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => Parser term -> Project -> Eff effs [Module term]
|
||||
parseModules parser p@Project{..} = distributeFor (projectFiles p) (parseModule p parser)
|
||||
|
||||
-- | Parse a file into a 'Module'.
|
||||
parseModule :: (Member (Exc SomeException) effs, Member Task effs) => Project -> Parser term -> File -> Eff effs (Module term)
|
||||
@ -206,15 +202,15 @@ withTermSpans :: ( HasField fields Span
|
||||
-> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
|
||||
withTermSpans recur term = withCurrentSpan (getField (termFAnnotation term)) (recur term)
|
||||
|
||||
resumingResolutionError :: (Applicative (m effects), Effectful m, Member Trace effects) => m (Resumable ResolutionError ': effects) a -> m effects a
|
||||
resumingResolutionError :: (Applicative (m effects), Effectful m, Member Trace effects, Effects effects) => m (Resumable ResolutionError ': effects) a -> m effects a
|
||||
resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionError:" <> show err) *> case err of
|
||||
NotFoundError nameToResolve _ _ -> pure nameToResolve
|
||||
GoImportError pathToResolve -> pure [pathToResolve])
|
||||
|
||||
resumingLoadError :: (Member Trace effects, AbstractHole address) => Evaluator address value (Resumable (LoadError address) ': effects) a -> Evaluator address value effects a
|
||||
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> (hole, lowerBound))
|
||||
resumingLoadError :: (Member Trace effects, AbstractHole address, Effects effects) => Evaluator address value (Resumable (LoadError address) ': effects) a -> Evaluator address value effects a
|
||||
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> (lowerBound, hole))
|
||||
|
||||
resumingEvalError :: Member Trace effects => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a
|
||||
resumingEvalError :: (Member Trace effects, Effects effects) => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a
|
||||
resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of
|
||||
DefaultExportError{} -> pure ()
|
||||
ExportError{} -> pure ()
|
||||
@ -223,15 +219,15 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *
|
||||
RationalFormatError{} -> pure 0
|
||||
FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
|
||||
|
||||
resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a
|
||||
resumingUnspecialized :: (Member Trace effects, AbstractHole value, Effects effects) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a
|
||||
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> hole)
|
||||
|
||||
resumingAddressError :: (AbstractHole value, Lower (Cell address value), Member Trace effects, Show address) => Evaluator address value (Resumable (AddressError address value) ': effects) a -> Evaluator address value effects a
|
||||
resumingAddressError :: (AbstractHole value, Lower (Cell address value), Member Trace effects, Show address, Effects effects) => Evaluator address value (Resumable (AddressError address value) ': effects) a -> Evaluator address value effects a
|
||||
resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> show err) *> case err of
|
||||
UnallocatedAddress _ -> pure lowerBound
|
||||
UninitializedAddress _ -> pure hole)
|
||||
|
||||
resumingValueError :: (Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a
|
||||
resumingValueError :: (Member Trace effects, Show address, Effects effects) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a
|
||||
resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of
|
||||
CallError val -> pure val
|
||||
StringError val -> pure (pack (show val))
|
||||
@ -247,7 +243,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err
|
||||
KeyValueError{} -> pure (hole, hole)
|
||||
ArithmeticError{} -> pure hole)
|
||||
|
||||
resumingEnvironmentError :: AbstractHole address => Evaluator address value (Resumable (EnvironmentError address) ': effects) a -> Evaluator address value effects (a, [Name])
|
||||
resumingEnvironmentError :: (AbstractHole address, Effects effects) => Evaluator address value (Resumable (EnvironmentError address) ': effects) a -> Evaluator address value effects ([Name], a)
|
||||
resumingEnvironmentError
|
||||
= runState []
|
||||
. reinterpret (\ (Resumable (FreeVariable name)) -> modify' (name :) $> hole)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||
module Semantic.IO
|
||||
( Destination(..)
|
||||
, Files
|
||||
@ -214,14 +214,20 @@ data Source blob where
|
||||
data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
|
||||
|
||||
-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
|
||||
data Files out where
|
||||
Read :: Source out -> Files out
|
||||
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
|
||||
FindFiles :: FilePath -> [String] -> [FilePath] -> Files [FilePath]
|
||||
Write :: Destination -> B.Builder -> Files ()
|
||||
data Files (m :: * -> *) out where
|
||||
Read :: Source out -> Files m out
|
||||
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files m Project
|
||||
FindFiles :: FilePath -> [String] -> [FilePath] -> Files m [FilePath]
|
||||
Write :: Destination -> B.Builder -> Files m ()
|
||||
|
||||
instance Effect Files where
|
||||
handleState c dist (Request (Read source) k) = Request (Read source) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (ReadProject rootDir dir language excludeDirs) k) = Request (ReadProject rootDir dir language excludeDirs) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (FindFiles dir exts paths) k) = Request (FindFiles dir exts paths) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Write destination builder) k) = Request (Write destination builder) (dist . (<$ c) . k)
|
||||
|
||||
-- | Run a 'Files' effect in 'IO'.
|
||||
runFiles :: (Member (Exc SomeException) effs, Member IO effs) => Eff (Files ': effs) a -> Eff effs a
|
||||
runFiles :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Effects effs) => Eff (Files ': effs) a -> Eff effs a
|
||||
runFiles = interpret $ \ files -> case files of
|
||||
Read (FromPath path) -> rethrowing (readBlobFromPath path)
|
||||
Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle)
|
||||
|
||||
@ -20,30 +20,30 @@ import qualified Language.Ruby.Assignment as Ruby
|
||||
import qualified Language.TypeScript.Assignment as TypeScript
|
||||
import qualified Language.JSON.Assignment as JSON
|
||||
|
||||
runParse :: (Member (Distribute WrappedTask) effs, Member Task effs) => TermRenderer output -> [Blob] -> Eff effs Builder
|
||||
runParse :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) => TermRenderer output -> [Blob] -> Eff effs Builder
|
||||
runParse JSONTermRenderer = withParsedBlobs (render . renderJSONTerm) >=> serialize JSON
|
||||
runParse SExpressionTermRenderer = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
|
||||
runParse ShowTermRenderer = withParsedBlobs (const (serialize Show))
|
||||
runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
|
||||
runParse DOTTermRenderer = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
|
||||
|
||||
runRubyParse :: Member (Distribute WrappedTask) effs => [Blob] -> Eff effs [Term (Sum Ruby.Syntax) ()]
|
||||
runRubyParse = flip distributeFor (\ blob -> WrapTask (do
|
||||
runRubyParse :: (Member Distribute effs, Member Task effs) => [Blob] -> Eff effs [Term (Sum Ruby.Syntax) ()]
|
||||
runRubyParse = flip distributeFor (\ blob -> do
|
||||
term <- parse rubyParser blob
|
||||
pure (() <$ term)))
|
||||
pure (() <$ term))
|
||||
|
||||
runTypeScriptParse :: Member (Distribute WrappedTask) effs => [Blob] -> Eff effs [Term (Sum TypeScript.Syntax) ()]
|
||||
runTypeScriptParse = flip distributeFor (\ blob -> WrapTask (do
|
||||
runTypeScriptParse :: (Member Distribute effs, Member Task effs) => [Blob] -> Eff effs [Term (Sum TypeScript.Syntax) ()]
|
||||
runTypeScriptParse = flip distributeFor (\ blob -> do
|
||||
term <- parse typescriptParser blob
|
||||
pure (() <$ term)))
|
||||
pure (() <$ term))
|
||||
|
||||
runJSONParse :: Member (Distribute WrappedTask) effs => [Blob] -> Eff effs [Term (Sum JSON.Syntax) ()]
|
||||
runJSONParse = flip distributeFor (\ blob -> WrapTask (do
|
||||
runJSONParse :: (Member Distribute effs, Member Task effs) => [Blob] -> Eff effs [Term (Sum JSON.Syntax) ()]
|
||||
runJSONParse = flip distributeFor (\ blob -> do
|
||||
term <- parse jsonParser blob
|
||||
pure (() <$ term)))
|
||||
pure (() <$ term))
|
||||
|
||||
withParsedBlobs :: (Member (Distribute WrappedTask) effs, Monoid output) => (forall syntax . (ConstructorName syntax, Foldable syntax, Functor syntax, HasDeclaration syntax, HasPackageDef syntax, Show1 syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> TaskEff output) -> [Blob] -> Eff effs output
|
||||
withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob)))
|
||||
withParsedBlobs :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs, Monoid output) => (forall syntax . (ConstructorName syntax, Foldable syntax, Functor syntax, HasDeclaration syntax, HasPackageDef syntax, Show1 syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> Eff effs output) -> [Blob] -> Eff effs output
|
||||
withParsedBlobs render = distributeFoldMap (\ blob -> parseSomeBlob blob >>= withSomeTerm (render blob))
|
||||
|
||||
parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] (Record Location))
|
||||
parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (`parse` blob) (someParser blobLanguage)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE ConstraintKinds, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||
module Semantic.Resolution where
|
||||
|
||||
import Control.Monad.Effect
|
||||
@ -35,11 +35,15 @@ resolutionMap Project{..} = case projectLanguage of
|
||||
JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs)
|
||||
_ -> send NoResolution
|
||||
|
||||
data Resolution output where
|
||||
NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution (Map FilePath FilePath)
|
||||
NoResolution :: Resolution (Map FilePath FilePath)
|
||||
data Resolution (m :: * -> *) output where
|
||||
NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution m (Map FilePath FilePath)
|
||||
NoResolution :: Resolution m (Map FilePath FilePath)
|
||||
|
||||
runResolution :: Member Files effs => Eff (Resolution ': effs) a -> Eff effs a
|
||||
instance Effect Resolution where
|
||||
handleState c dist (Request (NodeJSResolution path key paths) k) = Request (NodeJSResolution path key paths) (dist . (<$ c) . k)
|
||||
handleState c dist (Request NoResolution k) = Request NoResolution (dist . (<$ c) . k)
|
||||
|
||||
runResolution :: (Member Files effs, Effects effs) => Eff (Resolution ': effs) a -> Eff effs a
|
||||
runResolution = interpret $ \ res -> case res of
|
||||
NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs
|
||||
NoResolution -> pure Map.empty
|
||||
NoResolution -> pure Map.empty
|
||||
|
||||
@ -1,8 +1,7 @@
|
||||
{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators #-}
|
||||
{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators #-}
|
||||
module Semantic.Task
|
||||
( Task
|
||||
, TaskEff
|
||||
, WrappedTask(..)
|
||||
, Level(..)
|
||||
, RAlgebra
|
||||
-- * I/O
|
||||
@ -43,6 +42,7 @@ module Semantic.Task
|
||||
, Distribute
|
||||
, Eff
|
||||
, Exc
|
||||
, Lift
|
||||
, throwError
|
||||
, SomeException
|
||||
, Telemetry
|
||||
@ -82,19 +82,16 @@ import Serializing.Format hiding (Options)
|
||||
import System.Exit (die)
|
||||
|
||||
-- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
|
||||
type TaskEff = Eff '[Distribute WrappedTask
|
||||
, Task
|
||||
type TaskEff = Eff '[ Task
|
||||
, Resolution
|
||||
, IO.Files
|
||||
, Reader Config
|
||||
, Trace
|
||||
, Telemetry
|
||||
, Exc SomeException
|
||||
, IO]
|
||||
|
||||
-- | A wrapper for a 'Task', to embed in other effects.
|
||||
newtype WrappedTask a = WrapTask { unwrapTask :: TaskEff a }
|
||||
deriving (Applicative, Functor, Monad)
|
||||
, Distribute
|
||||
, Lift IO
|
||||
]
|
||||
|
||||
-- | A function to render terms or diffs.
|
||||
type Renderer i o = i -> o
|
||||
@ -141,33 +138,43 @@ runTaskWithConfig :: Config -> LogQueue -> StatQueue -> TaskEff a -> IO (Either
|
||||
runTaskWithConfig options logger statter task = do
|
||||
(result, stat) <- withTiming "run" [] $ do
|
||||
let run :: TaskEff a -> IO (Either SomeException a)
|
||||
run = runM . runError
|
||||
. runTelemetry logger statter
|
||||
. runTraceInTelemetry
|
||||
. runReader options
|
||||
. IO.runFiles
|
||||
. runResolution
|
||||
. runTaskF
|
||||
. runDistribute (run . unwrapTask)
|
||||
run
|
||||
= runM
|
||||
. runDistribute
|
||||
. runError
|
||||
. runTelemetry logger statter
|
||||
. runTraceInTelemetry
|
||||
. runReader options
|
||||
. IO.runFiles
|
||||
. runResolution
|
||||
. runTaskF
|
||||
run task
|
||||
queueStat statter stat
|
||||
pure result
|
||||
|
||||
runTraceInTelemetry :: Member Telemetry effects => Eff (Trace ': effects) a -> Eff effects a
|
||||
runTraceInTelemetry :: (Member Telemetry effects, Effects effects) => Eff (Trace ': effects) a -> Eff effects a
|
||||
runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
|
||||
|
||||
|
||||
-- | An effect describing high-level tasks to be performed.
|
||||
data Task output where
|
||||
Parse :: Parser term -> Blob -> Task term
|
||||
Analyze :: (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Task result
|
||||
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
|
||||
Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task (Diff syntax (Record fields1) (Record fields2))
|
||||
Render :: Renderer input output -> input -> Task output
|
||||
Serialize :: Format input -> input -> Task Builder
|
||||
data Task (m :: * -> *) output where
|
||||
Parse :: Parser term -> Blob -> Task m term
|
||||
Analyze :: (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Task m result
|
||||
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task m (Term f (Record (field ': fields)))
|
||||
Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task m (Diff syntax (Record fields1) (Record fields2))
|
||||
Render :: Renderer input output -> input -> Task m output
|
||||
Serialize :: Format input -> input -> Task m Builder
|
||||
|
||||
instance Effect Task where
|
||||
handleState c dist (Request (Parse parser blob) k) = Request (Parse parser blob) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Analyze run analysis) k) = Request (Analyze run analysis) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Decorate decorator term) k) = Request (Decorate decorator term) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Semantic.Task.Diff terms) k) = Request (Semantic.Task.Diff terms) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Render renderer input) k) = Request (Render renderer input) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k)
|
||||
|
||||
-- | Run a 'Task' effect by performing the actions in 'IO'.
|
||||
runTaskF :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Eff (Task ': effs) a -> Eff effs a
|
||||
runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, Effects effs) => Eff (Task ': effs) a -> Eff effs a
|
||||
runTaskF = interpret $ \ task -> case task of
|
||||
Parse parser blob -> runParser blob parser
|
||||
Analyze interpret analysis -> pure (interpret analysis)
|
||||
@ -188,7 +195,7 @@ data ParserCancelled = ParserTimedOut deriving (Show, Typeable)
|
||||
instance Exception ParserCancelled
|
||||
|
||||
-- | Parse a 'Blob' in 'IO'.
|
||||
runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term
|
||||
runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term
|
||||
runParser blob@Blob{..} parser = case parser of
|
||||
ASTParser language ->
|
||||
time "parse.tree_sitter_ast_parse" languageTag $ do
|
||||
@ -214,7 +221,7 @@ runParser blob@Blob{..} parser = case parser of
|
||||
, Apply Functor syntaxes
|
||||
, Element Syntax.Error syntaxes
|
||||
, Member (Exc SomeException) effs
|
||||
, Member IO effs
|
||||
, Member (Lift IO) effs
|
||||
, Member (Reader Config) effs
|
||||
, Member Telemetry effs
|
||||
, Member Trace effs
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-}
|
||||
module Semantic.Telemetry
|
||||
(
|
||||
-- Async telemetry interface
|
||||
@ -122,25 +122,29 @@ writeStat :: Member Telemetry effs => Stat -> Eff effs ()
|
||||
writeStat stat = send (WriteStat stat)
|
||||
|
||||
-- | A task which measures and stats the timing of another task.
|
||||
time :: (Member IO effs, Member Telemetry effs) => String -> [(String, String)] -> Eff effs output -> Eff effs output
|
||||
time :: (Member (Lift IO) effs, Member Telemetry effs) => String -> [(String, String)] -> Eff effs output -> Eff effs output
|
||||
time statName tags task = do
|
||||
(a, stat) <- withTiming statName tags task
|
||||
a <$ writeStat stat
|
||||
|
||||
|
||||
-- | Statting and logging effects.
|
||||
data Telemetry output where
|
||||
WriteStat :: Stat -> Telemetry ()
|
||||
WriteLog :: Level -> String -> [(String, String)] -> Telemetry ()
|
||||
data Telemetry (m :: * -> *) output where
|
||||
WriteStat :: Stat -> Telemetry m ()
|
||||
WriteLog :: Level -> String -> [(String, String)] -> Telemetry m ()
|
||||
|
||||
instance Effect Telemetry where
|
||||
handleState c dist (Request (WriteStat stat) k) = Request (WriteStat stat) (dist . (<$ c) . k)
|
||||
handleState c dist (Request (WriteLog level message pairs) k) = Request (WriteLog level message pairs) (dist . (<$ c) . k)
|
||||
|
||||
-- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
|
||||
runTelemetry :: Member IO effects => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a
|
||||
runTelemetry :: (Member (Lift IO) effects, Effects effects) => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a
|
||||
runTelemetry logger statter = interpret (\ t -> case t of
|
||||
WriteStat stat -> queueStat statter stat
|
||||
WriteLog level message pairs -> queueLogMessage logger level message pairs)
|
||||
|
||||
-- | Run a 'Telemetry' effect by ignoring statting/logging.
|
||||
ignoreTelemetry :: Eff (Telemetry ': effs) a -> Eff effs a
|
||||
ignoreTelemetry :: Effects effs => Eff (Telemetry ': effs) a -> Eff effs a
|
||||
ignoreTelemetry = interpret (\ t -> case t of
|
||||
WriteStat{} -> pure ()
|
||||
WriteLog{} -> pure ())
|
||||
|
||||
@ -42,33 +42,33 @@ justEvaluating
|
||||
. fmap reassociate
|
||||
. runLoadError
|
||||
. runUnspecialized
|
||||
. runResolutionError
|
||||
. runEnvironmentError
|
||||
. runEvalError
|
||||
. runResolutionError
|
||||
. runAddressError
|
||||
. runValueError
|
||||
|
||||
newtype UtilEff address a = UtilEff
|
||||
{ runUtilEff :: Eff '[ LoopControl address
|
||||
, Return address
|
||||
{ runUtilEff :: Eff '[ Exc (LoopControl address)
|
||||
, Exc (Return address)
|
||||
, Env address
|
||||
, Allocator address (Value address (UtilEff address))
|
||||
, Reader ModuleInfo
|
||||
, Modules address
|
||||
, State (ModuleTable (NonEmpty (Module (address, Environment address))))
|
||||
, Reader (ModuleTable (NonEmpty (Module (Environment address, address))))
|
||||
, Reader Span
|
||||
, Reader PackageInfo
|
||||
, Resumable (ValueError address (UtilEff address))
|
||||
, Resumable (AddressError address (Value address (UtilEff address)))
|
||||
, Resumable ResolutionError
|
||||
, Resumable EvalError
|
||||
, Resumable (EnvironmentError address)
|
||||
, Resumable ResolutionError
|
||||
, Resumable (Unspecialized (Value address (UtilEff address)))
|
||||
, Resumable (LoadError address)
|
||||
, Trace
|
||||
, Fresh
|
||||
, State (Heap address Latest (Value address (UtilEff address)))
|
||||
, IO
|
||||
, Lift IO
|
||||
] a
|
||||
}
|
||||
|
||||
@ -107,11 +107,9 @@ evaluateProject proxy parser lang paths = runTaskWithOptions debugOptions $ do
|
||||
pure (runTermEvaluator @_ @_ @(Value Precise (UtilEff Precise))
|
||||
(runReader (packageInfo package)
|
||||
(runReader (lowerBound @Span)
|
||||
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
|
||||
(fmap fst
|
||||
(runState (lowerBound @(ModuleTable (NonEmpty (Module (Precise, Environment Precise)))))
|
||||
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (Environment Precise, Precise)))))
|
||||
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
|
||||
(evaluate proxy id withTermSpans modules)))))))
|
||||
(evaluate proxy id withTermSpans modules))))))
|
||||
|
||||
evaluateProjectWithCaching proxy parser lang path = runTaskWithOptions debugOptions $ do
|
||||
project <- readProject Nothing path lang []
|
||||
@ -119,11 +117,9 @@ evaluateProjectWithCaching proxy parser lang path = runTaskWithOptions debugOpti
|
||||
modules <- topologicalSort <$> runImportGraph proxy package
|
||||
pure (runReader (packageInfo package)
|
||||
(runReader (lowerBound @Span)
|
||||
-- FIXME: This should really be a Reader effect but for https://github.com/joshvera/effects/issues/47
|
||||
(fmap fst
|
||||
(runState (lowerBound @(ModuleTable (NonEmpty (Module (Monovariant, Environment Monovariant)))))
|
||||
(runReader (lowerBound @(ModuleTable (NonEmpty (Module (Environment Monovariant, Monovariant)))))
|
||||
(raiseHandler (runModules (ModuleTable.modulePaths (packageModules package)))
|
||||
(evaluate proxy id withTermSpans modules))))))
|
||||
(evaluate proxy id withTermSpans modules)))))
|
||||
|
||||
|
||||
parseFile :: Parser term -> FilePath -> IO term
|
||||
|
||||
@ -12,17 +12,17 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "Go" $ do
|
||||
it "imports and wildcard imports" $ do
|
||||
((res, heap), _) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
|
||||
(_, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
|
||||
case ModuleTable.lookup "main.go" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ]
|
||||
(derefQName heap ("foo" :| []) env >>= deNamespace) `shouldBe` Just ("foo", ["New"])
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "imports with aliases (and side effects only)" $ do
|
||||
((res, heap), _) <- evaluate ["main1.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
|
||||
(_, (heap, res)) <- evaluate ["main1.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"]
|
||||
case ModuleTable.lookup "main1.go" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
Env.names env `shouldBe` [ "f", "main" ]
|
||||
(derefQName heap ("f" :| []) env >>= deNamespace) `shouldBe` Just ("f", ["New"])
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
@ -13,25 +13,25 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "PHP" $ do
|
||||
it "evaluates include and require" $ do
|
||||
((res, heap), _) <- evaluate ["main.php", "foo.php", "bar.php"]
|
||||
(_, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"]
|
||||
case ModuleTable.lookup "main.php" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
heapLookupAll addr heap `shouldBe` Just [unit]
|
||||
Env.names env `shouldBe` [ "bar", "foo" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "evaluates include_once and require_once" $ do
|
||||
((res, heap), _) <- evaluate ["main_once.php", "foo.php", "bar.php"]
|
||||
(_, (heap, res)) <- evaluate ["main_once.php", "foo.php", "bar.php"]
|
||||
case ModuleTable.lookup "main_once.php" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
heapLookupAll addr heap `shouldBe` Just [unit]
|
||||
Env.names env `shouldBe` [ "bar", "foo" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "evaluates namespaces" $ do
|
||||
((res, heap), _) <- evaluate ["namespaces.php"]
|
||||
(_, (heap, res)) <- evaluate ["namespaces.php"]
|
||||
case ModuleTable.lookup "namespaces.php" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
Env.names env `shouldBe` [ "Foo", "NS1" ]
|
||||
|
||||
(derefQName heap ("NS1" :| []) env >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
|
||||
|
||||
@ -14,9 +14,9 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "Python" $ do
|
||||
it "imports" $ do
|
||||
((res, heap), _) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]
|
||||
(_, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"]
|
||||
case ModuleTable.lookup "main.py" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
Env.names env `shouldContain` [ "a", "b" ]
|
||||
|
||||
(derefQName heap ("a" :| []) env >>= deNamespace) `shouldBe` Just ("a", ["foo"])
|
||||
@ -25,35 +25,35 @@ spec = parallel $ do
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "imports with aliases" $ do
|
||||
((res, _), _) <- evaluate ["main1.py", "a.py", "b/__init__.py", "b/c.py"]
|
||||
(_, (_, res)) <- evaluate ["main1.py", "a.py", "b/__init__.py", "b/c.py"]
|
||||
case ModuleTable.lookup "main1.py" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> Env.names env `shouldContain` [ "b", "e" ]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> Env.names env `shouldContain` [ "b", "e" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "imports using 'from' syntax" $ do
|
||||
((res, _), _) <- evaluate ["main2.py", "a.py", "b/__init__.py", "b/c.py"]
|
||||
(_, (_, res)) <- evaluate ["main2.py", "a.py", "b/__init__.py", "b/c.py"]
|
||||
case ModuleTable.lookup "main2.py" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "imports with relative syntax" $ do
|
||||
((res, heap), _) <- evaluate ["main3.py", "c/__init__.py", "c/utils.py"]
|
||||
(_, (heap, res)) <- evaluate ["main3.py", "c/__init__.py", "c/utils.py"]
|
||||
case ModuleTable.lookup "main3.py" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
Env.names env `shouldContain` [ "utils" ]
|
||||
(derefQName heap ("utils" :| []) env >>= deNamespace) `shouldBe` Just ("utils", ["to_s"])
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "subclasses" $ do
|
||||
((res, heap), _) <- evaluate ["subclass.py"]
|
||||
(_, (heap, res)) <- evaluate ["subclass.py"]
|
||||
case ModuleTable.lookup "subclass.py" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"bar\""]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"bar\""]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "handles multiple inheritance left-to-right" $ do
|
||||
((res, heap), _) <- evaluate ["multiple_inheritance.py"]
|
||||
(_, (heap, res)) <- evaluate ["multiple_inheritance.py"]
|
||||
case ModuleTable.lookup "multiple_inheritance.py" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"foo!\""]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"foo!\""]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
where
|
||||
|
||||
@ -19,29 +19,29 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "Ruby" $ do
|
||||
it "evaluates require_relative" $ do
|
||||
((res, heap), _) <- evaluate ["main.rb", "foo.rb"]
|
||||
(_, (heap, res)) <- evaluate ["main.rb", "foo.rb"]
|
||||
case ModuleTable.lookup "main.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)]
|
||||
Env.names env `shouldContain` [ "foo" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "evaluates load" $ do
|
||||
((res, heap), _) <- evaluate ["load.rb", "foo.rb"]
|
||||
(_, (heap, res)) <- evaluate ["load.rb", "foo.rb"]
|
||||
case ModuleTable.lookup "load.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)]
|
||||
Env.names env `shouldContain` [ "foo" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "evaluates load with wrapper" $ do
|
||||
((res, _), _) <- evaluate ["load-wrap.rb", "foo.rb"]
|
||||
(_, (_, res)) <- evaluate ["load-wrap.rb", "foo.rb"]
|
||||
res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
|
||||
|
||||
it "evaluates subclass" $ do
|
||||
((res, heap), _) <- evaluate ["subclass.rb"]
|
||||
(_, (heap, res)) <- evaluate ["subclass.rb"]
|
||||
case ModuleTable.lookup "subclass.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
heapLookupAll addr heap `shouldBe` Just [String "\"<bar>\""]
|
||||
Env.names env `shouldContain` [ "Bar", "Foo" ]
|
||||
|
||||
@ -49,53 +49,53 @@ spec = parallel $ do
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "evaluates modules" $ do
|
||||
((res, heap), _) <- evaluate ["modules.rb"]
|
||||
(_, (heap, res)) <- evaluate ["modules.rb"]
|
||||
case ModuleTable.lookup "modules.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
heapLookupAll addr heap `shouldBe` Just [String "\"<hello>\""]
|
||||
Env.names env `shouldContain` [ "Bar" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "handles break correctly" $ do
|
||||
((res, heap), _) <- evaluate ["break.rb"]
|
||||
(_, (heap, res)) <- evaluate ["break.rb"]
|
||||
case ModuleTable.lookup "break.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "handles next correctly" $ do
|
||||
((res, heap), _) <- evaluate ["next.rb"]
|
||||
(_, (heap, res)) <- evaluate ["next.rb"]
|
||||
case ModuleTable.lookup "next.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 8)]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 8)]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "calls functions with arguments" $ do
|
||||
((res, heap), _) <- evaluate ["call.rb"]
|
||||
(_, (heap, res)) <- evaluate ["call.rb"]
|
||||
case ModuleTable.lookup "call.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 579)]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 579)]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "evaluates early return statements" $ do
|
||||
((res, heap), _) <- evaluate ["early-return.rb"]
|
||||
(_, (heap, res)) <- evaluate ["early-return.rb"]
|
||||
case ModuleTable.lookup "early-return.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "has prelude" $ do
|
||||
((res, heap), _) <- evaluate ["preluded.rb"]
|
||||
(_, (heap, res)) <- evaluate ["preluded.rb"]
|
||||
case ModuleTable.lookup "preluded.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"<foo>\""]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"<foo>\""]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "evaluates __LINE__" $ do
|
||||
((res, heap), _) <- evaluate ["line.rb"]
|
||||
(_, (heap, res)) <- evaluate ["line.rb"]
|
||||
case ModuleTable.lookup "line.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)]
|
||||
Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "resolves builtins used in the prelude" $ do
|
||||
((res, heap), traces) <- evaluate ["puts.rb"]
|
||||
(traces, (heap, res)) <- evaluate ["puts.rb"]
|
||||
case ModuleTable.lookup "puts.rb" <$> res of
|
||||
Right (Just (Module _ (addr, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, addr) :| [])) -> do
|
||||
heapLookupAll addr heap `shouldBe` Just [Unit]
|
||||
traces `shouldContain` [ "\"hello\"" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
@ -15,15 +15,15 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "TypeScript" $ do
|
||||
it "imports with aliased symbols" $ do
|
||||
((res, _), _) <- evaluate ["main.ts", "foo.ts", "a.ts", "foo/b.ts"]
|
||||
(_, (_, res)) <- evaluate ["main.ts", "foo.ts", "a.ts", "foo/b.ts"]
|
||||
case ModuleTable.lookup "main.ts" <$> res of
|
||||
Right (Just (Module _ (_, env) :| [])) -> Env.names env `shouldBe` [ "bar", "quz" ]
|
||||
Right (Just (Module _ (env, _) :| [])) -> Env.names env `shouldBe` [ "bar", "quz" ]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "imports with qualified names" $ do
|
||||
((res, heap), _) <- evaluate ["main1.ts", "foo.ts", "a.ts"]
|
||||
(_, (heap, res)) <- evaluate ["main1.ts", "foo.ts", "a.ts"]
|
||||
case ModuleTable.lookup "main1.ts" <$> res of
|
||||
Right (Just (Module _ (_, env) :| [])) -> do
|
||||
Right (Just (Module _ (env, _) :| [])) -> do
|
||||
Env.names env `shouldBe` [ "b", "z" ]
|
||||
|
||||
(derefQName heap ("b" :| []) env >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
|
||||
@ -31,19 +31,19 @@ spec = parallel $ do
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "side effect only imports" $ do
|
||||
((res, _), _) <- evaluate ["main2.ts", "a.ts", "foo.ts"]
|
||||
(_, (_, res)) <- evaluate ["main2.ts", "a.ts", "foo.ts"]
|
||||
case ModuleTable.lookup "main2.ts" <$> res of
|
||||
Right (Just (Module _ (_, env) :| [])) -> env `shouldBe` lowerBound
|
||||
Right (Just (Module _ (env, _) :| [])) -> env `shouldBe` lowerBound
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
it "fails exporting symbols not defined in the module" $ do
|
||||
((res, _), _) <- evaluate ["bad-export.ts", "pip.ts", "a.ts", "foo.ts"]
|
||||
(_, (_, res)) <- evaluate ["bad-export.ts", "pip.ts", "a.ts", "foo.ts"]
|
||||
res `shouldBe` Left (SomeExc (inject @EvalError (ExportError "foo.ts" (name "pip"))))
|
||||
|
||||
it "evaluates early return statements" $ do
|
||||
((res, heap), _) <- evaluate ["early-return.ts"]
|
||||
(_, (heap, res)) <- evaluate ["early-return.ts"]
|
||||
case ModuleTable.lookup "early-return.ts" <$> res of
|
||||
Right (Just (Module _ (addr, _) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Float (Number.Decimal 123.0)]
|
||||
Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Float (Number.Decimal 123.0)]
|
||||
other -> expectationFailure (show other)
|
||||
|
||||
where
|
||||
|
||||
@ -18,11 +18,11 @@ import SpecHelpers hiding (reassociate)
|
||||
spec :: Spec
|
||||
spec = parallel $ do
|
||||
it "constructs integers" $ do
|
||||
(expected, _) <- evaluate (box (integer 123))
|
||||
(_, expected) <- evaluate (box (integer 123))
|
||||
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
||||
|
||||
it "calls functions" $ do
|
||||
(expected, _) <- evaluate $ do
|
||||
(_, expected) <- evaluate $ do
|
||||
identity <- closure [name "x"] lowerBound (variable (name "x"))
|
||||
call identity [box (integer 123)]
|
||||
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
||||
@ -38,7 +38,7 @@ evaluate
|
||||
. runEnvironmentError
|
||||
. runAddressError
|
||||
. runAllocator @Precise @_ @Val
|
||||
. (>>= deref . fst)
|
||||
. (>>= deref . snd)
|
||||
. runEnv lowerBound
|
||||
. runReturn
|
||||
. runLoopControl
|
||||
@ -48,8 +48,8 @@ reassociate = mergeExcs . mergeExcs . mergeExcs . Right
|
||||
|
||||
type Val = Value Precise SpecEff
|
||||
newtype SpecEff a = SpecEff
|
||||
{ runSpecEff :: Eff '[ LoopControl Precise
|
||||
, Return Precise
|
||||
{ runSpecEff :: Eff '[ Exc (LoopControl Precise)
|
||||
, Exc (Return Precise)
|
||||
, Env Precise
|
||||
, Allocator Precise Val
|
||||
, Resumable (AddressError Precise Val)
|
||||
@ -59,6 +59,6 @@ newtype SpecEff a = SpecEff
|
||||
, Reader PackageInfo
|
||||
, Fresh
|
||||
, State (Heap Precise Latest Val)
|
||||
, IO
|
||||
, Lift IO
|
||||
] a
|
||||
}
|
||||
|
||||
@ -242,10 +242,10 @@ diffWithParser :: ( HasField fields Data.Span.Span
|
||||
, Diffable syntax
|
||||
, HasDeclaration syntax
|
||||
, Hashable1 syntax
|
||||
, Member (Distribute WrappedTask) effs
|
||||
, Member Distribute effs
|
||||
, Member Task effs
|
||||
)
|
||||
=> Parser (Term syntax (Record fields))
|
||||
-> BlobPair
|
||||
-> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
|
||||
diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin
|
||||
diffWithParser parser blobs = distributeFor blobs (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin
|
||||
|
||||
@ -83,43 +83,44 @@ readFilePair paths = let paths' = fmap file paths in
|
||||
|
||||
type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise))
|
||||
, Resumable (AddressError Precise Val)
|
||||
, Resumable EvalError, Resumable (EnvironmentError Precise)
|
||||
, Resumable ResolutionError
|
||||
, Resumable EvalError
|
||||
, Resumable (EnvironmentError Precise)
|
||||
, Resumable (Unspecialized Val)
|
||||
, Resumable (LoadError Precise)
|
||||
, Trace
|
||||
, Fresh
|
||||
, State (Heap Precise Latest Val)
|
||||
, IO
|
||||
, Lift IO
|
||||
]
|
||||
type TestEvaluatingErrors = '[ ValueError Precise (UtilEff Precise)
|
||||
, AddressError Precise Val
|
||||
, ResolutionError
|
||||
, EvalError
|
||||
, EnvironmentError Precise
|
||||
, ResolutionError
|
||||
, Unspecialized Val
|
||||
, LoadError Precise
|
||||
]
|
||||
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (Precise, Environment Precise))))
|
||||
testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (Environment Precise, Precise))))
|
||||
-> IO
|
||||
( ( Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
|
||||
(ModuleTable (NonEmpty (Module (Precise, Environment Precise))))
|
||||
, Heap Precise Latest Val
|
||||
( [String]
|
||||
, ( Heap Precise Latest Val
|
||||
, Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors))
|
||||
(ModuleTable (NonEmpty (Module (Environment Precise, Precise))))
|
||||
)
|
||||
, [String]
|
||||
)
|
||||
testEvaluating
|
||||
= runM
|
||||
. fmap (\ ((res, traces), heap) -> ((res, heap), traces))
|
||||
. fmap (\ (heap, (traces, res)) -> (traces, (heap, res)))
|
||||
. runState lowerBound
|
||||
. runFresh 0
|
||||
. runReturningTrace
|
||||
. fmap reassociate
|
||||
. runLoadError
|
||||
. runUnspecialized
|
||||
. runResolutionError
|
||||
. runEnvironmentError
|
||||
. runEvalError
|
||||
. runResolutionError
|
||||
. runAddressError
|
||||
. runValueError @_ @Precise @(UtilEff Precise)
|
||||
|
||||
|
||||
2
vendor/effects
vendored
2
vendor/effects
vendored
@ -1 +1 @@
|
||||
Subproject commit 8181375d6386de302a8c9807dad2f096e8d490aa
|
||||
Subproject commit f1f98bb60f7df34359f4a6e1487353a0c644311b
|
||||
Loading…
Reference in New Issue
Block a user