github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 06:11:49 +03:00
Code Issues Projects Releases Wiki Activity

Clean up a bunch of algebras.

Browse Source
This commit is contained in:
Rob Rix 2018-10-22 20:30:07 -04:00
parent 314aff5d56
commit 21f17ff56f
13 changed files with 24 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Control/Abstract/Modules.hs
View File

@ -99,7 +99,7 @@ instance ( Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))
)
=> Carrier (Modules address :+: sig) (ModulesC address m) where
ret = ModulesC . const . ret
eff op = ModulesC (\ paths -> (alg paths \/ (eff . handlePure (flip runModulesC paths))) op)
eff op = ModulesC (\ paths -> (alg paths \/ eff . handleReader paths runModulesC) op)
where alg paths (Load name k) = askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup name >>= flip runModulesC paths . k
alg paths (Lookup path k) = askModuleTable >>= flip runModulesC paths . k . fmap (runMerging . foldMap1 (Merging . moduleBody)) . ModuleTable.lookup path
alg paths (Resolve names k) = runModulesC (k (find (`Set.member` paths) names)) paths

4
src/Data/Abstract/Address/Hole.hs
View File

@ -40,13 +40,13 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
)
=> Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where
ret = demoteA . ret
eff = alg \/ AllocatorC . eff . handlePure runAllocatorC
eff = alg \/ AllocatorC . eff . handleCoercible
where alg (Alloc name k) = Total <$> promoteA (eff (L (Alloc name ret))) >>= k
instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
=> Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where
ret = demoteD . ret
eff = alg \/ DerefC . eff . handlePure runDerefC
eff = alg \/ DerefC . eff . handleCoercible
where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k
alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k

4
src/Data/Abstract/Address/Located.hs
View File

@ -43,13 +43,13 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m)
)
=> Carrier (Allocator (Located address) :+: sig) (AllocatorC (Located address) m) where
ret = demoteA . ret
eff = alg \/ AllocatorC . eff . handlePure runAllocatorC
eff = alg \/ AllocatorC . eff . handleCoercible
where alg (Alloc name k) = Located <$> promoteA (eff (L (Alloc name ret))) <*> currentPackage <*> currentModule <*> pure name <*> ask >>= k
instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m)
=> Carrier (Deref value :+: sig) (DerefC (Located address) value m) where
ret = demoteD . ret
eff = alg \/ DerefC . eff . handlePure runDerefC
eff = alg \/ DerefC . eff . handleCoercible
where alg (DerefCell cell k) = promoteD (eff (L (DerefCell cell ret))) >>= k
alg (AssignCell value cell k) = promoteD (eff (L (AssignCell value cell ret))) >>= k

4
src/Data/Abstract/Address/Monovariant.hs
View File

@ -20,12 +20,12 @@ instance Show Monovariant where
instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where
ret = AllocatorC . ret
eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC))
eff = AllocatorC . (alg \/ eff . handleCoercible)
where alg (Alloc name k) = runAllocatorC (k (Monovariant name))
instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where
ret = DerefC . ret
eff = DerefC . (alg \/ (eff . handlePure runDerefC))
eff = DerefC . (alg \/ eff . handleCoercible)
where alg (DerefCell cell k) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k
alg (AssignCell value cell k) = runDerefC (k (Set.insert value cell))

4
src/Data/Abstract/Address/Precise.hs
View File

@ -19,12 +19,12 @@ instance Show Precise where
instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where
ret = AllocatorC . ret
eff = AllocatorC . (alg \/ (eff . handlePure runAllocatorC))
eff = AllocatorC . (alg \/ eff . handleCoercible)
where alg (Alloc _ k) = Precise <$> fresh >>= runAllocatorC . k
instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where
ret = DerefC . ret
eff = DerefC . (alg \/ (eff . handlePure runDerefC))
eff = DerefC . (alg \/ eff . handleCoercible)
where alg (DerefCell cell k) = runDerefC (k (fst <$> Set.minView cell))
alg (AssignCell value _ k) = runDerefC (k (Set.singleton value))

6
src/Data/Abstract/Value/Abstract.hs
View File

@ -31,7 +31,7 @@ instance ( Member (Allocator address) sig
)
=> Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Evaluator term address Abstract m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
where alg eval = \case
Function _ params body k -> do
env <- foldr (\ name rest -> do
@ -48,7 +48,7 @@ instance ( Member (Allocator address) sig
instance (Carrier sig m, Alternative m, Monad m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where
ret = BooleanC . ret
eff = BooleanC . (alg \/ eff . handlePure runBooleanC)
eff = BooleanC . (alg \/ eff . handleCoercible)
where alg (Boolean _ k) = runBooleanC (k Abstract)
alg (AsBool _ k) = runBooleanC (k True) <|> runBooleanC (k False)
alg (Disjunction a b k) = (runBooleanC a <|> runBooleanC b) >>= runBooleanC . k
@ -61,7 +61,7 @@ instance ( Member (Abstract.Boolean Abstract) sig
)
=> Carrier (While Abstract :+: sig) (WhileC Abstract m) where
ret = WhileC . ret
eff = WhileC . (alg \/ eff . handlePure runWhileC)
eff = WhileC . (alg \/ eff . handleCoercible)
where alg (Abstract.While cond body k) = do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))

6
src/Data/Abstract/Value/Concrete.hs
View File

@ -74,7 +74,7 @@ instance ( FreeVariables term
)
=> Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Evaluator term address (Value term address) m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
where alg eval = \case
Abstract.Function name params body k -> do
packageInfo <- currentPackage
@ -107,7 +107,7 @@ instance ( Member (Reader ModuleInfo) sig
)
=> Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where
ret = BooleanC . ret
eff = BooleanC . (alg \/ (eff . handlePure runBooleanC))
eff = BooleanC . (alg \/ eff . handleCoercible)
where alg :: Abstract.Boolean (Value term address) (BooleanC (Value term address) m) (BooleanC (Value term address) m a) -> m a
alg = \case
Abstract.Boolean b k -> runBooleanC . k $! Boolean b
@ -140,7 +140,7 @@ instance ( Member (Reader ModuleInfo) sig
-- )
-- => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff (InterposeC (Resumable (BaseError (UnspecializedError (Value term address)))) m))) where
-- ret = WhileC . ret
-- eff = WhileC . (alg \/ (eff . handlePure runWhileC))
-- eff = WhileC . (alg \/ eff . handleCoercible)
-- where alg = \case
-- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError (Value term address))))
-- (\(Resumable (BaseError _ _ (UnspecializedError _)) k) -> throwAbort) (runEvaluator (loop (\continue -> do

6
src/Data/Abstract/Value/Type.hs
View File

@ -253,7 +253,7 @@ instance ( Member (Allocator address) sig
)
=> Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Evaluator term address Type m)) where
ret = FunctionC . const . ret
eff op = FunctionC (\ eval -> (alg eval \/ (eff . handlePure (flip runFunctionC eval))) op)
eff op = FunctionC (\ eval -> (alg eval \/ eff . handleReader eval runFunctionC) op)
where alg eval = \case
Abstract.Function _ params body k -> do
(env, tvars) <- foldr (\ name rest -> do
@ -285,7 +285,7 @@ instance ( Member (Reader ModuleInfo) sig
)
=> Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where
ret = BooleanC . ret
eff = BooleanC . (alg \/ (eff . handlePure runBooleanC))
eff = BooleanC . (alg \/ eff . handleCoercible)
where alg (Abstract.Boolean _ k) = runBooleanC (k Bool)
alg (Abstract.AsBool t k) = unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False))
alg (Abstract.Disjunction t1 t2 k) = ((runBooleanC t1 >>= unify Bool) <|> (runBooleanC t2 >>= unify Bool) >>= runBooleanC . k)
@ -298,7 +298,7 @@ instance ( Member (Abstract.Boolean Type) sig
)
=> Carrier (Abstract.While Type :+: sig) (WhileC Type m) where
ret = WhileC . ret
eff = WhileC . (alg \/ (eff . handlePure runWhileC))
eff = WhileC . (alg \/ eff . handleCoercible)
where alg (Abstract.While cond body k) = do
cond' <- runWhileC cond
ifthenelse cond' (runWhileC body *> empty) (runWhileC (k unit))

2
src/Semantic/Distribute.hs
View File

@ -56,4 +56,4 @@ newtype DistributeC m a = DistributeC { runDistributeC :: m a }
instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where
ret = DistributeC . ret
eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ (eff . handlePure runDistributeC))
eff = DistributeC . ((\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) \/ eff . handleCoercible)

2
src/Semantic/IO.hs
View File

@ -243,7 +243,7 @@ newtype FilesC m a = FilesC { runFilesC :: m a }
instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where
ret = FilesC . ret
eff = FilesC . (alg \/ (eff . handlePure runFilesC))
eff = FilesC . (alg \/ eff . handleCoercible)
where alg = \case
Read (FromPath path) k -> (readBlobFromPath path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k
Read (FromHandle handle) k -> (readBlobsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k

2
src/Semantic/Resolution.hs
View File

@ -63,6 +63,6 @@ newtype ResolutionC m a = ResolutionC { runResolutionC :: m a }
instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where
ret = ResolutionC . ret
eff = ResolutionC . (alg \/ (eff . handlePure runResolutionC))
eff = ResolutionC . (alg \/ eff . handleCoercible)
where alg (NodeJSResolution dir prop excludeDirs k) = nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k
alg (NoResolution k) = runResolutionC (k Map.empty)

4
src/Semantic/Task.hs
View File

@ -205,7 +205,7 @@ newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a
instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where
ret = TraceInTelemetryC . ret
eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ (eff . handlePure runTraceInTelemetryC))
eff = TraceInTelemetryC . ((\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) \/ eff . handleCoercible)
-- | An effect describing high-level tasks to be performed.
@ -249,7 +249,7 @@ newtype TaskC m a = TaskC { runTaskC :: m a }
instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Config) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where
ret = TaskC . ret
eff = TaskC . (alg \/ (eff . handlePure runTaskC))
eff = TaskC . (alg \/ eff . handleCoercible)
where alg = \case
Parse parser blob k -> runParser blob parser >>= runTaskC . k
Analyze interpret analysis k -> runTaskC (k (interpret analysis))

2
src/Semantic/Telemetry.hs
View File

@ -158,7 +158,7 @@ newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) ->
instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where
ret = TelemetryC . const . ret
eff op = TelemetryC (\ queues -> (alg queues \/ (eff . handlePure (flip runTelemetryC queues))) op)
eff op = TelemetryC (\ queues -> (alg queues \/ eff . handleReader queues runTelemetryC) op)
where alg queues (WriteStat stat k) = queueStat (snd queues) stat *> runTelemetryC k queues
alg queues (WriteLog level message pairs k) = queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues