diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017, Nikita Volkov +Copyright (c) 2019 Nikita Volkov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/fx.cabal b/fx.cabal --- a/fx.cabal +++ b/fx.cabal @@ -1,51 +1,118 @@ -name: - fx -version: - 0.10.1 -synopsis: - Horizontally composable effects +cabal-version: 3.4 +name: fx +version: 0.11 +synopsis: Modular effectful computations with explicit environments and errors description: - This library provides for the horizontal composition of effects, - serving as an alternative - to the monad transformers stacking composition. - It is expected to be faster, but no comparison has been performed yet. -homepage: - https://github.com/nikita-volkov/fx -bug-reports: - https://github.com/nikita-volkov/fx/issues -author: - Nikita Volkov -maintainer: - Nikita Volkov -copyright: - (c) 2017, Nikita Volkov -license: - MIT -license-file: - LICENSE -build-type: - Simple -cabal-version: - >=1.10 + A lightweight library for writing effectful computations with explicit + environment dependencies and error handling. Provides value-based abstractions + for effects without deep monad transformer stacks. + Key features: explicit env/err types, composable and safe resource management and + concurrency, and compatibility with Ports and Adapters architecture. + +category: Effects, Resources +homepage: https://github.com/nikita-volkov/fx +bug-reports: https://github.com/nikita-volkov/fx/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2019 Nikita Volkov +license: MIT +license-file: LICENSE + source-repository head - type: - git - location: - git://github.com/nikita-volkov/fx.git + type: git + location: https://github.com/nikita-volkov/fx -library - hs-source-dirs: - library +common base + default-language: Haskell2010 default-extensions: - Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples - default-language: - Haskell2010 + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + ParallelListComp + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + +common executable + import: base + ghc-options: + -O2 + -threaded + -with-rtsopts=-N + -rtsopts + -funbox-strict-fields + +common test + import: base + ghc-options: + -threaded + -with-rtsopts=-N + +library + import: base + hs-source-dirs: library exposed-modules: - Fx.EitherEffect - Fx.Transform + Fx + other-modules: - Fx.EitherEffect.Types + Fx.Conc + Fx.Future + Fx.Fx Fx.Prelude + Fx.Scope + Fx.Strings + build-depends: - base >= 4.9 && < 5 + base >=4.9 && <5, + monad-parallel >=0.8 && <0.9, + mtl >=2.2 && <3, + stm >=2.5 && <3, + text >=1 && <3, + transformers >=0.5 && <0.8, + +test-suite test + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-tool-depends: + hspec-discover:hspec-discover >=2 && <3 + + build-depends: + fx, + hspec >=2.11 && <3, + rerebase <2, diff --git a/library/Fx.hs b/library/Fx.hs new file mode 100644 --- /dev/null +++ b/library/Fx.hs @@ -0,0 +1,57 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Fx + ( -- * Fx + Fx, + + -- ** Execution + RunsFx (..), + + -- ** Environment handling + scoping, + mapEnv, + + -- ** Error handling + throwErr, + handleErr, + mapErr, + exposeErr, + absorbErr, + + -- ** Concurrency + concurrently, + + -- ** IO execution + + -- | + -- These functions leak abstraction in one way or the other, + -- requiring you to ensure that your code doesn't throw unexpected exceptions. + -- `try` and `catch` are your tools for that. + -- + -- Besides these functions `Fx` also has an instance of `MonadIO`, + -- which provides the only non-leaky way of running IO, catching all possible exceptions. + runTotalIO, + runPartialIO, + runExceptionalIO, + + -- * Scope + Scope, + acquire, + registerRelease, + + -- * Exceptions + FxException (..), + FxExceptionReason (..), + ) +where + +import Fx.Conc +import Fx.Fx +import Fx.Prelude +import Fx.Scope + +-- TODO: Move to the Fx module. +instance MonadParallel (Fx env err) where + bindM2 f l r = + join $ concurrently $ \lift -> + liftA2 f (lift l) (lift r) diff --git a/library/Fx/Conc.hs b/library/Fx/Conc.hs new file mode 100644 --- /dev/null +++ b/library/Fx/Conc.hs @@ -0,0 +1,74 @@ +-- | +-- Concurrent computations with Alternative and Applicative composition +module Fx.Conc + ( -- * Conc + Conc (..), + concurrently, + ) +where + +import qualified Fx.Future as Future +import Fx.Fx (Fx, RunsFx (..)) +import Fx.Prelude + +-- | +-- Wrapper over `Fx`, whose instances compose by running computations on separate threads. +newtype Conc env err res = Conc (Fx env err res) + +deriving instance Functor (Conc env err) + +deriving instance Bifunctor (Conc env) + +instance Applicative (Conc env err) where + pure = Conc . pure + (<*>) (Conc m1) (Conc m2) = Conc do + future1 <- Future.async m1 + res2 <- m2 + res1 <- Future.await future1 + return (res1 res2) + +instance Alternative (Conc env err) where + empty = Conc do + Future.await empty + (<|>) (Conc m1) (Conc m2) = Conc do + future1 <- Future.async m1 + future2 <- Future.async m2 + -- Race the futures - the first to complete wins + result <- Future.await (future1 <|> future2) + -- Cancel the loser thread + -- Both threads get killed; the winner has already completed so killThread is a no-op + Future.cancel future1 + Future.cancel future2 + return result + +-- | +-- Execute concurrent effects in either one or a combination of the following ways: +-- +-- - __Complete__: Run in parallel and wait for all results (Applicative instance) +-- - __Race__: Run in parallel and choose the result of the first one to produce it or to fail (Alternative instance) +-- +-- E.g., +-- +-- > selectDataById :: Int64 -> Fx env err (Metadata, File) +-- > selectDataById id = +-- > concurrently $ \lift -> +-- > (,) +-- > <$> lift (selectMetadataById id) +-- > <*> lift (getFileById id) +-- +-- One interesting use of the `Alternative` instance is implementing timeouts: +-- +-- > timeout :: Int -> Fx env err res -> Fx env err (Maybe res) +-- > timeout millis action = +-- > concurrently $ \lift -> +-- > lift action +-- > <|> lift (runTotalIO (Nothing <$ threadDelay (fromIntegral millis * 1000)))) +concurrently :: + (forall f. (Alternative f) => (forall x. Fx env err x -> f x) -> f res) -> + Fx env err res +concurrently build = + case build Conc of + Conc fx -> fx + +instance RunsFx env err (Conc env err) where + runFx = Conc diff --git a/library/Fx/EitherEffect.hs b/library/Fx/EitherEffect.hs deleted file mode 100644 --- a/library/Fx/EitherEffect.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Fx.EitherEffect -( - EitherEffect, - liftLeft, - liftRight, -) -where - -import Fx.Prelude -import Fx.EitherEffect.Types - - -instance Functor either => Functor (EitherEffect left right either) where - fmap mapping (EitherEffect either) = - EitherEffect (\ leftContext rightContext -> fmap mapping (either leftContext rightContext)) - -instance Applicative either => Applicative (EitherEffect left right either) where - pure x = - EitherEffect (\ _ _ -> pure x) - (<*>) (EitherEffect left) (EitherEffect right) = - EitherEffect (\ leftContext rightContext -> left leftContext rightContext <*> right leftContext rightContext) - -instance Monad either => Monad (EitherEffect left right either) where - return = pure - (>>=) (EitherEffect left) rightK = - EitherEffect $ \ leftContext rightContext -> do - leftResult <- left leftContext rightContext - case rightK leftResult of - EitherEffect right -> right leftContext rightContext - -instance MonadIO either => MonadIO (EitherEffect left right either) where - liftIO io = - EitherEffect (\ _ _ -> liftIO io) - -{-| -Lift the first of the two effects. --} -liftLeft :: left result -> EitherEffect left right either result -liftLeft effect = - EitherEffect (\ leftContext rightContext -> leftContext effect) - -{-| -Lift the second of the two effects. --} -liftRight :: right result -> EitherEffect left right either result -liftRight effect = - EitherEffect (\ leftContext rightContext -> rightContext effect) diff --git a/library/Fx/EitherEffect/Types.hs b/library/Fx/EitherEffect/Types.hs deleted file mode 100644 --- a/library/Fx/EitherEffect/Types.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Fx.EitherEffect.Types -where - -import Fx.Prelude - -{-| -A sum of two effects. -Allows for horizontal composition of monads instead of nesting as with monad transformers. - -To execute it use 'Fx.Transform.eitherEffect'. --} -newtype EitherEffect leftEffect rightEffect context result = - EitherEffect ((forall x. leftEffect x -> context x) -> (forall x. rightEffect x -> context x) -> context result) diff --git a/library/Fx/Future.hs b/library/Fx/Future.hs new file mode 100644 --- /dev/null +++ b/library/Fx/Future.hs @@ -0,0 +1,117 @@ +-- | +-- Future abstraction for concurrent computations +module Fx.Future + ( Future, + async, + await, + cancel, + ) +where + +import Fx.Fx +import Fx.Prelude +import qualified Fx.Strings as Strings +import GHC.Stack (callStack) + +-- | +-- Handle to a result of an action which may still be being executed on another thread. +data Future err res + = Future + (Maybe ThreadId) + (Compose STM (Either (Maybe err)) res) + +instance Functor (Future err) where + fmap f (Future tid result) = Future tid (fmap f result) + +instance Applicative (Future err) where + pure a = Future Nothing (pure a) + Future tid1 resultF <*> Future tid2 resultA = + Future (tid1 <|> tid2) (resultF <*> resultA) + +instance Alternative (Future err) where + empty = Future Nothing empty + Future tid1 result1 <|> Future tid2 result2 = + -- When one completes, cancel the other + Future (tid1 <|> tid2) (result1 <|> result2) + +instance Bifunctor Future where + bimap lf rf = mapImpl (mapCompose (fmap (bimap (fmap lf) rf))) + +mapImpl :: + ( Compose STM (Either (Maybe err1)) res1 -> + Compose STM (Either (Maybe err2)) res2 + ) -> + Future err1 res1 -> + Future err2 res2 +mapImpl fn (Future tid m) = Future tid (fn m) + +-- | +-- Spawn a thread and start running an effect on it, +-- returning the associated future. +-- +-- Fatal errors on the spawned thread are guaranteed to get propagated to the top. +-- By fatal errors we mean calls to `error`, `fail` and uncaught exceptions. +-- +-- Normal errors (the explicit @err@ parameter) will only propagate +-- if you use `await` at some point. +-- +-- __Warning:__ +-- It is your responsibility to ensure that the whole future executes +-- before the running `Fx` finishes. +-- Otherwise you will lose the environment in scope of which the future executes. +-- To achieve that use `await`. +async :: Fx env err res -> Fx env err' (Future err res) +async (Fx m) = + Fx $ ReaderT $ \(FxEnv unmask crash env) -> lift $ do + futureVar <- newEmptyTMVarIO + + let handler = \case + ThreadKilled -> void $ atomically (tryPutTMVar futureVar (Left Nothing)) + exc -> throwIO exc + tid <- forkIO $ handle handler do + tid <- myThreadId + + let childCrash stack tids dls = crash stack (tid : tids) dls + + finalize <- + catch + ( do + res <- runExceptT (runReaderT m (FxEnv unmask childCrash env)) + return (atomically (putTMVar futureVar (first Just res))) + ) + ( \exc -> return $ do + case fromException exc of + -- Catch calls to `error`. + Just errorCall -> crash callStack [] (ErrorCallFxExceptionReason errorCall) + -- Catch anything else we could miss. Just in case. + _ -> crash callStack [] (BugFxExceptionReason (Strings.unexpectedException exc)) + atomically (putTMVar futureVar (Left Nothing)) + ) + + finalize + + return $ Future (Just tid) $ Compose $ readTMVar futureVar + +-- | +-- Block until the future completes either with a result or an error. +await :: Future err res -> Fx env err res +await (Future _ m) = + Fx $ ReaderT $ \(FxEnv unmask crash _) -> + ExceptT $ + join $ + catch + ( do + futureStatus <- unmask (atomically (getCompose m)) + return $ case futureStatus of + Right res -> return (Right res) + Left (Just err) -> return (Left err) + Left Nothing -> fail "Waiting for a future that crashed" + ) + ( \(exc :: SomeException) -> return $ do + crash callStack [] (BugFxExceptionReason (Strings.failedWaitingForResult exc)) + fail "Thread crashed with uncaught exception waiting for result." + ) + +cancel :: Future err res -> Fx env err' () +cancel (Future Nothing _) = return () +cancel (Future (Just tid) _) = runTotalIO (\_ -> killThread tid `catch` \(_ :: SomeException) -> return ()) diff --git a/library/Fx/Fx.hs b/library/Fx/Fx.hs new file mode 100644 --- /dev/null +++ b/library/Fx/Fx.hs @@ -0,0 +1,301 @@ +-- | +-- Core Fx operations and execution +module Fx.Fx + ( Fx (..), + FxEnv (..), + FxException (..), + FxExceptionReason (..), + + -- * Execution + runFxInIO, + RunsFx (..), + + -- ** Environment handling + mapEnv, + + -- ** Error handling + throwErr, + handleErr, + mapErr, + exposeErr, + absorbErr, + + -- ** IO execution + runTotalIO, + runPartialIO, + runExceptionalIO, + ) +where + +import Fx.Prelude +import qualified Fx.Strings as Strings +import GHC.Stack (CallStack, HasCallStack, callStack, prettyCallStack) + +-- * Helper types and instances + +-- | +-- Runtime and application environment. +data FxEnv env + = FxEnv + -- | Unmasking function. + (forall a. IO a -> IO a) + -- | Crash. + (CallStack -> [ThreadId] -> FxExceptionReason -> IO ()) + -- | User environment. + env + +-- | +-- Fatal failure of an `Fx` application. +data FxException = FxException [ThreadId] FxExceptionReason CallStack + +-- | +-- Reason of a fatal failure of an `Fx` application. +data FxExceptionReason + = UncaughtExceptionFxExceptionReason SomeException + | ErrorCallFxExceptionReason ErrorCall + | BugFxExceptionReason String + +instance Show FxException where + show (FxException tids reason stack) = + Strings.fatalErrorAtThreadPath tids (show reason) ++ "\n\nCallStack (from origin of error):\n" ++ prettyCallStack stack + +instance Exception FxException + +instance Show FxExceptionReason where + show = \case + UncaughtExceptionFxExceptionReason exc -> Strings.uncaughtException exc + ErrorCallFxExceptionReason errorCall -> show errorCall + BugFxExceptionReason details -> Strings.bug details + +-- * Fx type and instances + +-- | +-- Effectful computation with explicit errors in the context of provided environment. +-- +-- Think of it as a combination of `ReaderT` and `ExceptT` over `IO`, with some extra features for concurrency and error handling. +newtype Fx env err res = Fx (ReaderT (FxEnv env) (ExceptT err IO) res) + +deriving instance Functor (Fx env err) + +deriving instance Applicative (Fx env err) + +deriving instance (Monoid err) => Alternative (Fx env err) + +deriving instance Monad (Fx env err) + +deriving instance (Monoid err) => MonadPlus (Fx env err) + +instance MonadFail (Fx env err) where + fail msg = Fx $ + ReaderT $ + \(FxEnv _ crash _) -> liftIO $ do + crash callStack [] (ErrorCallFxExceptionReason (ErrorCall msg)) + fail "Crashed" + +instance MonadIO (Fx env SomeException) where + liftIO io = Fx (ReaderT (\(FxEnv unmask _ _) -> ExceptT (try (unmask io)))) + +instance MonadError err (Fx env err) where + throwError err = Fx (lift (throwE err)) + catchError fx handler = Fx $ ReaderT $ \fxEnv -> ExceptT $ do + a <- runExceptT (let Fx m = fx in runReaderT m fxEnv) + case a of + Right res -> return (Right res) + Left err -> case handler err of + Fx m -> runExceptT (runReaderT m fxEnv) + +instance Bifunctor (Fx env) where + bimap lf rf = mapTransformers (mapReaderT (mapExceptT (fmap (bimap lf rf)))) + +mapTransformers :: + ( ReaderT (FxEnv env1) (ExceptT err1 IO) res1 -> + ReaderT (FxEnv env2) (ExceptT err2 IO) res2 + ) -> + Fx env1 err1 res1 -> + Fx env2 err2 res2 +mapTransformers fn (Fx m) = Fx (fn m) + +-- * IO Execution + +------------------------- + +-- | +-- Execute an effect with no environment and all errors handled. +-- +-- Conventionally, this is what should be placed in the @main@ function. +runFxInIO :: (HasCallStack) => Fx () Void res -> IO res +runFxInIO (Fx m) = uninterruptibleMask $ \unmask -> do + fatalErrChan <- newTQueueIO + resVar <- newEmptyTMVarIO + + _ <- forkIO $ do + tid <- myThreadId + + finalize <- + let crash stack tids reason = atomically (writeTQueue fatalErrChan (FxException (tid : tids) reason stack)) + fxEnv = FxEnv unmask crash () + in catch + ( do + resOrVoid <- runExceptT (runReaderT m fxEnv) + return $ case resOrVoid of + Right res -> atomically (putTMVar resVar res) + Left a -> + catch + ( do + _ <- evaluate a + crash callStack [] (BugFxExceptionReason "Unexpected void") + ) + (\errorCall -> crash callStack [] (ErrorCallFxExceptionReason errorCall)) + ) + ( \exc -> return $ case fromException exc of + -- Catch calls to `error`. + Just errorCall -> crash callStack [] (ErrorCallFxExceptionReason errorCall) + -- Catch anything else we could miss. Just in case. + _ -> crash callStack [] (BugFxExceptionReason (Strings.unexpectedException exc)) + ) + + -- Throw errors or post the result + finalize + + -- Wait for fatal error or result + join $ + catch + ( unmask $ + atomically $ + asum + [ do + fatalErr <- readTQueue fatalErrChan + return $ throwIO fatalErr, + do + res <- readTMVar resVar + return $ return res + ] + ) + ( \(exc :: SomeException) -> + case fromException exc of + Just (exc :: AsyncException) -> throwIO exc + _ -> throwIO (FxException [] (BugFxExceptionReason (Strings.failedWaitingForFinalResult exc)) callStack) + ) + +-- | +-- Turn a non-failing IO action into an effect. +-- +-- __Warning:__ +-- It is your responsibility to ensure that it does not throw exceptions! +runTotalIO :: (env -> IO res) -> Fx env err res +runTotalIO io = Fx $ + ReaderT $ + \(FxEnv unmask crash env) -> + lift $ + catch + (unmask (io env)) + ( \(exc :: SomeException) -> do + crash callStack [] (UncaughtExceptionFxExceptionReason exc) + fail "Unhandled exception in runTotalIO. Got propagated to top." + ) + +-- | +-- Run IO which produces either an error or result. +-- +-- __Warning:__ +-- It is your responsibility to ensure that it does not throw exceptions! +runPartialIO :: (env -> IO (Either err res)) -> Fx env err res +runPartialIO io = runTotalIO io >>= either throwErr return + +-- | +-- Run IO which only throws a specific type of exception. +-- +-- __Warning:__ +-- It is your responsibility to ensure that it doesn't throw any other exceptions! +runExceptionalIO :: (Exception exc) => (env -> IO res) -> Fx env exc res +runExceptionalIO io = + Fx $ + ReaderT $ + \(FxEnv unmask crash env) -> ExceptT $ + catch (fmap Right (unmask (io env))) $ + \exc -> case fromException exc of + Just exc' -> return (Left exc') + Nothing -> do + crash callStack [] (UncaughtExceptionFxExceptionReason exc) + fail "Unhandled exception in runExceptionalIO. Got propagated to top." + +-- | +-- Map the environment. +-- Please notice that the expected function is contravariant. +mapEnv :: (b -> a) -> Fx a err res -> Fx b err res +mapEnv fn (Fx m) = + Fx $ + ReaderT $ + \(FxEnv unmask crash env) -> + runReaderT m (FxEnv unmask crash (fn env)) + +-- * Classes + +------------------------- + +-- ** Fx Running + +------------------------- + +-- | +-- Support for running of `Fx`. +-- +-- Apart from other things this is your interface to turn `Fx` into `IO`. +class RunsFx env err m | m -> env, m -> err where + runFx :: Fx env err res -> m res + +-- | +-- Executes an effect with no environment and all errors handled. +instance RunsFx () Void IO where + runFx = runFxInIO + +instance RunsFx () err (ExceptT err IO) where + runFx fx = ExceptT (runFx (exposeErr fx)) + +instance RunsFx env err (ReaderT env (ExceptT err IO)) where + runFx fx = ReaderT (\env -> ExceptT (runFx (mapEnv (const env) (exposeErr fx)))) + +instance RunsFx env err (Fx env err) where + runFx = id + +-- ** Error Handling + +------------------------- + +-- | +-- Interrupt the current computation raising an error. +-- +-- Same as `throwError` of `MonadError`. +throwErr :: err -> Fx env err res +throwErr = Fx . lift . throwE + +-- | +-- Handle error in another failing action. +-- Sort of like a bind operation over the error type parameter. +-- +-- Similar to `handleError` of `MonadError` but allows changing the error type. +handleErr :: (a -> Fx env b res) -> Fx env a res -> Fx env b res +handleErr handler = mapTransformers $ \m -> ReaderT $ \unmask -> ExceptT $ do + a <- runExceptT (runReaderT m unmask) + case a of + Right res -> return (Right res) + Left err -> case handler err of + Fx m -> runExceptT (runReaderT m unmask) + +-- | +-- Map the error. +mapErr :: (a -> b) -> Fx env a res -> Fx env b res +mapErr mapper = handleErr (throwErr . mapper) + +-- | +-- Expose the error in result, +-- producing an action, which is compatible with any error type. +-- +-- Almost the same as `tryError` of `MonadError`, but allows changing the error type. +exposeErr :: Fx env a res -> Fx env b (Either a res) +exposeErr = absorbErr Left . fmap Right + +-- | +-- Map from error to result, leaving the error be anything. +absorbErr :: (a -> res) -> Fx env a res -> Fx env b res +absorbErr fn = handleErr (pure . fn) diff --git a/library/Fx/Prelude.hs b/library/Fx/Prelude.hs --- a/library/Fx/Prelude.hs +++ b/library/Fx/Prelude.hs @@ -1,58 +1,73 @@ module Fx.Prelude -( - module Exports, -) + ( module Exports, + mapCompose, + ) where - --- base -------------------------- - import Control.Applicative as Exports import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports +import Control.Concurrent.STM as Exports hiding (orElse) import Control.Exception as Exports -import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM) +import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) +import Control.Monad.Error.Class as Exports (MonadError (..), catchError, throwError) +import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.Parallel as Exports (MonadFork (forkExec), MonadParallel (bindM2)) import Control.Monad.ST as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Cont as Exports hiding (callCC, shift) +import Control.Monad.Trans.Except as Exports (Except, ExceptT (ExceptT), catchE, except, mapExcept, mapExceptT, runExcept, runExceptT, throwE, withExcept, withExceptT) +import Control.Monad.Trans.Maybe as Exports +import Control.Monad.Trans.Reader as Exports (Reader, ReaderT (ReaderT), mapReader, mapReaderT, runReader, runReaderT, withReader, withReaderT) +import Control.Monad.Trans.State.Strict as Exports (State, StateT (StateT), evalState, evalStateT, execState, execStateT, mapState, mapStateT, runState, runStateT, withState, withStateT) +import Control.Monad.Trans.Writer.Strict as Exports (Writer, WriterT (..), execWriter, execWriterT, mapWriter, mapWriterT, runWriter) +import Data.Bifunctor as Exports import Data.Bits as Exports -import Data.Bool as Exports hiding (bool) +import Data.Bool as Exports import Data.Char as Exports +import Data.Coerce as Exports import Data.Complex as Exports import Data.Data as Exports import Data.Dynamic as Exports import Data.Either as Exports import Data.Fixed as Exports import Data.Foldable as Exports -import Data.Function as Exports hiding ((.), id, (&)) -import Data.Functor as Exports hiding (($>)) -import Data.Int as Exports +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Compose as Exports +import Data.Functor.Contravariant as Exports import Data.IORef as Exports +import Data.Int as Exports import Data.Ix as Exports -import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl') +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports -import Data.Monoid as Exports +import Data.Monoid as Exports hiding (Alt) import Data.Ord as Exports +import Data.Proxy as Exports import Data.Ratio as Exports import Data.STRef as Exports import Data.String as Exports +import Data.Text as Exports (Text) import Data.Traversable as Exports import Data.Tuple as Exports import Data.Unique as Exports import Data.Version as Exports +import Data.Void as Exports import Data.Word as Exports -import Debug.Trace as Exports hiding (traceShowId, traceM, traceShowM) +import Debug.Trace as Exports import Foreign.ForeignPtr as Exports import Foreign.Ptr as Exports import Foreign.StablePtr as Exports import Foreign.Storable as Exports -import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead) -import GHC.Exts as Exports (lazy, inline, sortWith, groupWith) +import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports import Numeric as Exports -import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports (Handle, hClose) @@ -61,12 +76,10 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports -import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P) -import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec) -import Text.Printf as Exports (printf, hPrintf) -import Text.Read as Exports (Read(..), readMaybe, readEither) +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) --- transformers -------------------------- -import Control.Monad.IO.Class as Exports +mapCompose :: (f (g a) -> f' (g' a')) -> Compose f g a -> Compose f' g' a' +mapCompose fn (Compose m) = Compose (fn m) diff --git a/library/Fx/Scope.hs b/library/Fx/Scope.hs new file mode 100644 --- /dev/null +++ b/library/Fx/Scope.hs @@ -0,0 +1,97 @@ +-- | +-- Scope abstraction for resource management +module Fx.Scope + ( -- * Scope + Scope (..), + acquire, + releasing, + registerRelease, + scoping, + ) +where + +import Fx.Fx +import Fx.Prelude + +-- | +-- Instructions of how to acquire and release a resource of type `env` and which may fail with `err`. +newtype Scope err env = Scope (Fx () err (env, Fx () err ())) + +instance Functor (Scope err) where + fmap f (Scope m) = Scope $ do + (env, release) <- m + return (f env, release) + +instance Applicative (Scope err) where + pure env = Scope (pure (env, pure ())) + Scope m1 <*> Scope m2 = + Scope $ + liftA2 (\(env1, release1) (env2, release2) -> (env1 env2, release2 *> release1)) m1 m2 + +instance Monad (Scope err) where + return = pure + Scope m >>= f = + Scope do + (env, release) <- m + let Scope m2 = f env + (env2, release2) <- m2 + return (env2, release2 *> release) + +instance Bifunctor Scope where + bimap lf rf (Scope m) = Scope (bimap lf (bimap rf (first lf)) m) + second = fmap + +-- | +-- Create a resource provider from an acquiring effect. +-- +-- To add a release action, use 'releasing'. +acquire :: Fx () err env -> Scope err env +acquire acquireFx = Scope do + env <- acquireFx + return (env, pure ()) + +-- | +-- Add a release action to an existing resource provider. +-- +-- Example: +-- +-- > fileInWriteMode :: FilePath -> Scope IOError Handle +-- > fileInWriteMode path = +-- > releasing hClose (acquire (openFile path WriteMode)) +releasing :: Fx env err () -> Scope err env -> Scope err env +releasing release (Scope m) = Scope $ do + (env, existingRelease) <- m + return (env, existingRelease >> closeEnv env release) + +-- | +-- Schedule an action to be run after the scope is exited. +registerRelease :: Fx () err () -> Scope err () +registerRelease release = + Scope $ pure ((), release) + +-- | +-- Execute Fx in the scope of a provided environment. +scoping :: Scope err env -> Fx env err res -> Fx env' err res +scoping (Scope (Fx acquire)) (Fx fx) = + Fx $ + ReaderT $ + \(FxEnv unmask crash _) -> ExceptT $ do + let providerFxEnv = FxEnv unmask crash () + acquisition <- runExceptT (runReaderT acquire providerFxEnv) + case acquisition of + Left err -> return (Left err) + Right (env, (Fx release)) -> do + resOrErr <- runExceptT (runReaderT fx (FxEnv unmask crash env)) + releasing <- runExceptT (runReaderT release providerFxEnv) + return (resOrErr <* releasing) + +closeEnv :: env -> Fx env err res -> Fx env' err res +closeEnv env (Fx fx) = + Fx $ + ReaderT $ + \(FxEnv unmask crash _) -> + ExceptT $ + runExceptT (runReaderT fx (FxEnv unmask crash env)) + +instance RunsFx () err (Scope err) where + runFx fx = Scope (fmap (\env -> (env, pure ())) fx) diff --git a/library/Fx/Strings.hs b/library/Fx/Strings.hs new file mode 100644 --- /dev/null +++ b/library/Fx/Strings.hs @@ -0,0 +1,32 @@ +module Fx.Strings where + +import Fx.Prelude + +failedWaitingForFinalResult :: SomeException -> String +failedWaitingForFinalResult exc = + showString "Failed waiting for final result: " (show exc) + +failedWaitingForResult :: SomeException -> String +failedWaitingForResult exc = + showString "Failed waiting for result: " (show exc) + +unexpectedException :: SomeException -> String +unexpectedException exc = + showString "Unexpected exception: " (show exc) + +uncaughtException :: SomeException -> String +uncaughtException exc = + showString "Uncaught exception: " (show exc) + +fatalErrorAtThreadPath :: [ThreadId] -> String -> String +fatalErrorAtThreadPath = + let showTids = intercalate "/" . fmap (drop 9 . show) + in \tids reason -> + showString ("Fatal error at thread path /") $ + showString (showTids tids) $ + showString ". " $ + reason + +bug :: String -> String +bug details = + showString "Bug in the \"fx\" library. Please report it to maintainers. " details diff --git a/library/Fx/Transform.hs b/library/Fx/Transform.hs deleted file mode 100644 --- a/library/Fx/Transform.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Fx.Transform -where - -import Fx.Prelude -import Fx.EitherEffect.Types - - -{-| -Natural transformation. -An abstraction over the transformation of kind-2 @input@ to @output@, both producing the same @result@. --} -newtype input --> output = - Transform (forall result. input result -> output result) - -{-| -Given a natural transformation of the left monad and a natural transformation of the right monad, -produces a natural transformation of either of them. --} -eitherEffect :: Monad either => (left --> either) -> (right --> either) -> (EitherEffect left right either --> either) -eitherEffect (Transform leftTrans) (Transform rightTrans) = - Transform (\ (EitherEffect context) -> context leftTrans rightTrans) - -instance Category (-->) where - id = Transform id - (.) (Transform left) (Transform right) = Transform (left . right) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,93 @@ +module Main where + +import Fx +import Test.Hspec +import Prelude hiding (choose) + +main :: IO () +main = hspec do + it "Error call on main thread" do + res <- try $ runFx $ error "A" + case res of + Left (FxException _ (ErrorCallFxExceptionReason _) _) -> return () + Left exc -> expectationFailure (show exc) + _ -> expectationFailure "Right" + + it "Fail" do + testException + (fail "A") + ( \case + FxException _ (ErrorCallFxExceptionReason _) _ -> True + _ -> False + ) + + it "Racing completes with first result" do + -- Test that racing returns the first result + let slowAction = do + -- Wrap in exception handler to catch ThreadKilled + runTotalIO $ \_ -> + catch + (threadDelay 1000000) -- 1 second + ( \case + ThreadKilled -> return () -- Just return on kill, we will check the kill in the test + exc -> throwIO exc + ) + return (1 :: Int) + + let fastAction = do + return (2 :: Int) + + -- Race them using concurrently + result <- runFx $ concurrently $ \lift -> + lift slowAction <|> lift fastAction + + -- The fast action should win + result `shouldBe` 2 + + it "Racing kills the losing thread" do + -- Test that the losing thread is actually killed + completedRef <- newIORef False + killedRef <- newIORef False + + let slowAction = do + -- This will be killed before it completes + runTotalIO $ \_ -> do + -- Use catch to detect if thread is killed + catch + (threadDelay 5000000 >> writeIORef completedRef True) -- 5 seconds + ( \case + ThreadKilled -> writeIORef killedRef True + _ -> pure () + ) + return (1 :: Int) + + let fastAction = do + return (2 :: Int) + + -- Race them using concurrently + result <- runFx $ concurrently $ \lift -> + lift slowAction <|> lift fastAction + + -- The fast action should win + result `shouldBe` 2 + + -- Give a moment for the kill signal to be processed + threadDelay 100000 -- 100ms + + -- The slow action should NOT have completed normally + completed <- readIORef completedRef + completed `shouldBe` False + + -- The slow action should have been killed + killed <- readIORef killedRef + killed `shouldBe` True + +testException :: Fx () Void a -> (FxException -> Bool) -> IO () +testException fx validateExc = do + res <- try @FxException $ runFx $ fx + case res of + Left exc -> + if validateExc exc + then return () + else expectationFailure (show exc) + Right _ -> expectationFailure "No exception"