From 21f17ff56f9bef22a7607f8361e159568d5df2d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 22 Oct 2018 20:30:07 -0400 Subject: [PATCH] Clean up a bunch of algebras. --- src/Control/Abstract/Modules.hs | 2 +- src/Data/Abstract/Address/Hole.hs | 4 ++-- src/Data/Abstract/Address/Located.hs | 4 ++-- src/Data/Abstract/Address/Monovariant.hs | 4 ++-- src/Data/Abstract/Address/Precise.hs | 4 ++-- src/Data/Abstract/Value/Abstract.hs | 6 +++--- src/Data/Abstract/Value/Concrete.hs | 6 +++--- src/Data/Abstract/Value/Type.hs | 6 +++--- src/Semantic/Distribute.hs | 2 +- src/Semantic/IO.hs | 2 +- src/Semantic/Resolution.hs | 2 +- src/Semantic/Task.hs | 4 ++-- src/Semantic/Telemetry.hs | 2 +- 13 files changed, 24 insertions(+), 24 deletions(-) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 6871304c2..d1cda2cd5 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -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 diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index 9d9c3599c..107fec6f0 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -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 diff --git a/src/Data/Abstract/Address/Located.hs b/src/Data/Abstract/Address/Located.hs index 754e5fbb3..ece08b11a 100644 --- a/src/Data/Abstract/Address/Located.hs +++ b/src/Data/Abstract/Address/Located.hs @@ -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 diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index 03224cda8..0a4dbd741 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -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)) diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index 0c9e4089b..50326dc55 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -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)) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 692adf0e5..f2022d012 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -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)) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 3ce83356a..14f7a44ec 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -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 diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 80faa00ec..935086dc0 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -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)) diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index d95266a13..8567cdb36 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -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) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index fb2b1a392..5246454cb 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -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 diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index c4707da4e..5b793ea84 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -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) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 20d6f9fd5..cc468ee12 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -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)) diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index fab89f3d5..a1ebcb2f4 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -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