packages feed

fx (empty) → 0.4

raw patch · 7 files changed

+869/−0 lines, 7 filesdep +QuickCheckdep +basedep +fxsetup-changed

Dependencies added: QuickCheck, base, fx, quickcheck-instances, rerebase, selective, stm, tasty, tasty-hunit, tasty-quickcheck, text, transformers, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2019 Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fx.cabal view
@@ -0,0 +1,49 @@+name: fx+version: 0.4+synopsis: Revamped effect system+category: Effects, Resources+homepage: https://github.com/nikita-volkov/fx+bug-reports: https://github.com/nikita-volkov/fx/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2019 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >=1.10++source-repository head+  type: git+  location: git://github.com/nikita-volkov/fx.git++library+  hs-source-dirs: library+  default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples+  default-language: Haskell2010+  exposed-modules:+    Fx+  other-modules:+    Fx.Prelude+    Fx.Strings+  build-depends:+    base >=4.9 && <5,+    selective >=0.3 && <0.4,+    stm >=2.5 && <3,+    text >=1 && <2,+    transformers >=0.5 && <0.6,+    unordered-containers >=0.2.10 && <0.3++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  default-extensions: BangPatterns, DeriveDataTypeable, DeriveGeneric, DeriveFunctor, DeriveTraversable, FlexibleContexts, FlexibleInstances, LambdaCase, NoImplicitPrelude, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies+  default-language: Haskell2010+  main-is: Main.hs+  build-depends:+    fx,+    QuickCheck >=2.13 && <3,+    quickcheck-instances >=0.3.22 && <0.4,+    rerebase <2,+    tasty >=1.2.3 && <2,+    tasty-hunit >=0.10.0.2 && <0.11,+    tasty-quickcheck >=0.10.1 && <0.11
+ library/Fx.hs view
@@ -0,0 +1,594 @@+module Fx+(+  -- * Fx+  Fx,+  -- ** Environment handling+  provideAndUse,+  handleEnv,+  -- ** Concurrency+  start,+  wait,+  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` are `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,+  runSTM,+  -- * Provider+  Provider,+  acquireAndRelease,+  pool,+  -- * Future+  Future,+  -- * Conc+  Conc,+  -- * Classes+  -- ** FxRunning+  FxRunning(..),+  -- ** ErrHandling+  ErrHandling(..),+  exposeErr,+  absorbErr,+  -- ** EnvMapping+  EnvMapping(..),+  -- * Exceptions+  FxException(..),+  FxExceptionReason(..),+)+where++import Fx.Prelude hiding (app)+import qualified Data.Text as Text+import qualified Data.HashSet as HashSet+import qualified Fx.Strings as Strings+++-- * IO+-------------------------++{-|+Execute an effect with no environment and all errors handled.++Conventionally, this is what should be placed in the @main@ function.+-}+runFxInIO :: Fx () Void res -> IO res+runFxInIO (Fx m) = uninterruptibleMask $ \ unmask -> do++  fatalErrChan <- newTQueueIO+  resVar <- newEmptyTMVarIO++  forkIO $ do++    tid <- myThreadId++    finalize <- let+      crash tids reason = atomically (writeTQueue fatalErrChan (FxException (tid : tids) reason))+      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 [] (BugFxExceptionReason "Unexpected void")+                  )+                  (crash [] . ErrorCallFxExceptionReason)+          )+          (\ exc -> return $ case fromException exc of+            -- Catch calls to `error`.+            Just errorCall -> crash [] (ErrorCallFxExceptionReason errorCall)+            -- Catch anything else we could miss. Just in case.+            _ -> crash [] (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))))+++-- * Fx+-------------------------++{-|+Effectful computation with explicit errors in the context of provided environment.++Calling `fail` causes the whole app to interrupt outputting a message to console.+`fail` is intended to be used in events which you expect never to happen,+and hence which should be considered bugs.+It is similar to calling `fail` on IO,+with a major difference of the error never getting lost in a concurrent environment.++Calling `fail` results in `ErrorCallFxExceptionReason` in the triggerred `FxException`.+Thus in effect it is the same as calling the `error` function.+-}+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 Selective (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 [] (ErrorCallFxExceptionReason (ErrorCall msg))+    fail "Crashed"++instance MonadIO (Fx env SomeException) where+  liftIO io = Fx (ReaderT (\ (FxEnv unmask _ _) -> ExceptT (try (unmask io))))++instance Bifunctor (Fx env) where+  bimap lf rf = mapFx (mapReaderT (mapExceptT (fmap (bimap lf rf))))++{-|+Runtime and application environment.+-}+data FxEnv env = FxEnv (forall a. IO a -> IO a) ([ThreadId] -> FxExceptionReason -> IO ()) env++mapFx fn (Fx m) = Fx (fn m)++{-|+Turn a non-failing IO action into an effect.++__Warning:__+It is your responsibility to ensure that it does not throw exceptions!+-}+runTotalIO :: IO res -> Fx env err res+runTotalIO io = Fx $ ReaderT $ \ (FxEnv unmask crash _) -> lift $+  catch (unmask io)+    (\ (exc :: SomeException) -> do+      crash [] (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 :: 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 => IO res -> Fx env exc res+runExceptionalIO io =+  Fx $ ReaderT $ \ (FxEnv unmask crash _) -> ExceptT $+  catch (fmap Right (unmask io)) $ \ exc -> case fromException exc of+    Just exc' -> return (Left exc')+    Nothing -> do+      crash [] (UncaughtExceptionFxExceptionReason exc)+      fail "Unhandled exception in runExceptionalIO. Got propagated to top."++{-|+Run STM, crashing in case of STM exceptions.++Same as @`runTotalIO` . `atomically`@.+-}+runSTM :: STM res -> Fx env err res+runSTM = runTotalIO . atomically++{-|+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 `wait` 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 `wait`.+-}+start :: Fx env err res -> Fx env err' (Future err res)+start (Fx m) =+  Fx $ ReaderT $ \ (FxEnv unmask crash env) -> lift $ do++    futureVar <- newEmptyTMVarIO++    forkIO $ do++      tid <- myThreadId++      let childCrash tids dls = crash (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 [] (ErrorCallFxExceptionReason errorCall)+              -- Catch anything else we could miss. Just in case.+              _ -> crash [] (BugFxExceptionReason (Strings.unexpectedException exc))+            atomically (putTMVar futureVar (Left Nothing))+          )++      finalize++    return $ Future $ Compose $ readTMVar futureVar++{-|+Block until the future completes either with a result or an error.+-}+wait :: Future err res -> Fx env err res+wait (Future m) = Fx $ ReaderT $ \ (FxEnv unmask crash env) -> 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 [] (BugFxExceptionReason (Strings.failedWaitingForResult exc))+    fail "Thread crashed with uncaught exception waiting for result."+  )++{-|+Execute concurrent effects.+-}+concurrently :: Conc env err res -> Fx env err res+concurrently (Conc fx) = fx++{-|+Execute Fx in the scope of a provided environment.+-}+provideAndUse :: Provider err env -> Fx env err res -> Fx env' err res+provideAndUse (Provider (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)++{-|+Collapse an env handler into an environmental effect.++__Warning:__+This function leaks the abstraction over the environment.+It is your responsibility to ensure that you don't use it to return+the environment and use it outside of the handler's scope.+-}+handleEnv :: (env -> Fx env err res) -> Fx env err res+handleEnv handler =+  Fx $ ReaderT $ \ (FxEnv unmask crash env) ->+    case handler env of+      Fx rdr -> runReaderT rdr (FxEnv unmask crash env)+++-- * Future+-------------------------++{-|+Handle to a result of an action which may still be being executed on another thread.++The way you deal with it is thru the `start` and `wait` functions.+-}+newtype Future err res = Future (Compose STM (Either (Maybe err)) res)+  deriving (Functor, Applicative)++{-|+Decides whether to wait for the result of another future.+-}+deriving instance Selective (Future err)++instance Bifunctor Future where+  bimap lf rf = mapFuture (mapCompose (fmap (bimap (fmap lf) rf)))++mapFuture fn (Future m) = Future (fn m)+++-- * Conc+-------------------------++{-|+Wrapper over `Fx`,+whose instances compose by running computations on separate threads.++You can turn `Fx` into `Conc` using `runFx`.+-}+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 <- start m1+    res2 <- m2+    res1 <- wait future1+    return (res1 res2)++{-|+Spawns a computation,+deciding whether to wait for it.+-}+instance Selective (Conc env err) where+  select (Conc choose) (Conc act) = Conc $ do+    actFtr <- start act+    chooseRes <- choose+    case chooseRes of+      Left a -> do+        aToB <- wait actFtr+        return (aToB a)+      Right b -> return b++mapConc fn (Conc m) = Conc (fn m)+++-- * Provider+-------------------------++{-|+Effectful computation with explicit errors,+which encompasses environment acquisition and releasing.++Composes well, allowing you to merge multiple providers into one.++Builds up on ideas expressed in http://www.haskellforall.com/2013/06/the-resource-applicative.html+and later released as the \"managed\" package.+-}+newtype Provider err env = Provider (Fx () err (env, Fx () err ()))++instance Functor (Provider err) where+  fmap f (Provider m) = Provider $ do+    (env, release) <- m+    return (f env, release)++instance Applicative (Provider err) where+  pure env = Provider (pure (env, pure ()))+  Provider m1 <*> Provider m2 = Provider $+    liftA2 (\ (env1, release1) (env2, release2) -> (env1 env2, release2 *> release1)) m1 m2++instance Monad (Provider err) where+  return = pure+  (>>=) (Provider m1) k2 = Provider $ do+    (env1, release1) <- m1+    (env2, release2) <- case k2 env1 of Provider m2 -> m2+    return (env2, release2 >> release1)++instance MonadIO (Provider SomeException) where+  liftIO = runFx . liftIO++instance Bifunctor Provider where+  bimap lf rf (Provider m) = Provider (bimap lf (bimap rf (first lf)) m)+  second = fmap++{-|+Create a resource provider from acquiring and releasing effects.+-}+acquireAndRelease :: Fx () err env -> (env -> Fx () err ()) -> Provider err env+acquireAndRelease acquire release = Provider $ do+  env <- acquire+  return (env, release env)++{-|+Convert a single resource provider into a pool provider.++The wrapper provider acquires the specified amount of resources using the original provider,+and returns a modified version of the original provider,+whose acquisition and releasing merely takes one resource out of the pool and puts it back when done.+No actual acquisition or releasing happens in the wrapped provider.+No errors get raised in it either.++Use this when you need to access a resource concurrently.+-}+pool :: Int -> Provider err env -> Provider err (Provider err' env)+pool poolSize (Provider acquire) = Provider $ do+  queue <- runSTM newTQueue+  replicateM_ poolSize $ do+    handle <- acquire+    runSTM $ writeTQueue queue handle    +  let+    resourceProvider = Provider $ do+      (env, releaseResource) <- runSTM $ readTQueue queue+      return (env, runSTM (writeTQueue queue (env, releaseResource)))+    release = do+      releasers <- runSTM $ do+        list <- flushTQueue queue+        guard (length list == poolSize)+        return (fmap snd list)+      sequence_ releasers+    in return (resourceProvider, release)+++-- * Classes+-------------------------++-- ** Fx Running+-------------------------++{-|+Support for running of `Fx`.++Apart from other things this is your interface to turn `Fx` into `IO` or `Conc`.+-}+class FxRunning 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 FxRunning () Void IO where+  runFx = runFxInIO++instance FxRunning () err (ExceptT err IO) where+  runFx fx = ExceptT (runFx (exposeErr fx))++instance FxRunning env err (ReaderT env (ExceptT err IO)) where+  runFx fx = ReaderT (\ env -> ExceptT (runFx (mapEnv (const env) (exposeErr fx))))++{-|+Executes an effect with no environment and all errors handled in `Fx`+with any environment and error.++Same as @(`mapEnv` (`const` ()) . `first` `absurd`)@.+-}+instance FxRunning () Void (Fx env err) where+  runFx = mapEnv (const ()) . first absurd++instance FxRunning env err (Conc env err) where+  runFx = Conc++instance FxRunning () err (Provider err) where+  runFx fx = Provider (fmap (\ env -> (env, pure ())) fx)++-- ** ErrHandling+-------------------------++{-|+Support for error handling.++Functions provided by this class are particularly helpful,+when you need to map into error of type `Void`.+-}+class ErrHandling m where++  {-|+  Interrupt the current computation raising an error.+  -}+  throwErr :: err -> m err res++  {-|+  Handle error in another failing action.+  Sort of like a bind operation over the error type parameter.+  -}+  handleErr :: (a -> m b res) -> m a res -> m b res++{-|+Expose the error in result,+producing an action, which is compatible with any error type.+-}+exposeErr :: (ErrHandling m, Functor (m a), Applicative (m b)) => m a res -> m b (Either a res)+exposeErr = absorbErr Left . fmap Right++{-|+Map from error to result, leaving the error be anything.+-}+absorbErr :: (ErrHandling m, Applicative (m b)) => (a -> res) -> m a res -> m b res+absorbErr fn = handleErr (pure . fn)++instance ErrHandling (Fx env) where+  throwErr = Fx . lift . throwE+  handleErr handler = mapFx $ \ 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)++instance ErrHandling Future where+  throwErr = Future . Compose . return . Left . Just+  handleErr handler = mapFuture $ \ m -> Compose $ do+    a <- getCompose m+    case a of+      Right res -> return (Right res)+      Left b -> case b of+        Just err -> case handler err of+          Future m' -> getCompose m'+        Nothing -> return (Left Nothing)++deriving instance ErrHandling (Conc env)++-- ** Env Mapping+-------------------------++{-|+Support for mapping of the environment.+-}+class EnvMapping m where+  {-|+  Map the environment.+  Please notice that the expected function is contravariant.+  -}+  mapEnv :: (b -> a) -> m a err res -> m b err res++instance EnvMapping Fx where+  mapEnv fn (Fx m) =+    Fx $ ReaderT $ \ (FxEnv unmask crash env) ->+      runReaderT m (FxEnv unmask crash (fn env))++deriving instance EnvMapping Conc+++-- * Exceptions+-------------------------++{-|+Fatal failure of an `Fx` application.+Informs of an unrecoverable condition that the application has reached.+It is not meant to be caught,+because it implies that there is either a bug in your code or+a bug in the "fx" library itself, which needs reporting.++Consists of a list of thread identifiers specifying the nesting path of+the faulty thread and the reason of failure.+-}+data FxException = FxException [ThreadId] FxExceptionReason++instance Show FxException where+  show (FxException tids reason) = Strings.fatalErrorAtThreadPath tids (show reason)++instance Exception FxException++{-|+Reason of a fatal failure of an `Fx` application.+-}+data FxExceptionReason =+  UncaughtExceptionFxExceptionReason SomeException |+  ErrorCallFxExceptionReason ErrorCall |+  BugFxExceptionReason String++instance Show FxExceptionReason where+  show = \ case+    UncaughtExceptionFxExceptionReason exc -> Strings.uncaughtException exc+    ErrorCallFxExceptionReason errorCall -> show errorCall+    BugFxExceptionReason details -> Strings.bug details
+ library/Fx/Prelude.hs view
@@ -0,0 +1,107 @@+module Fx.Prelude+( +  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.Exception as Exports+import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.IO.Class as Exports+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+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+import Data.Functor.Compose as Exports+import Data.Functor.Contravariant as Exports+import Data.Int as Exports+import Data.IORef 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.NonEmpty as Exports (NonEmpty(..))+import Data.Maybe 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.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+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 (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)+import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Numeric as Exports+import Prelude as Exports hiding (fail, 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)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+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 Unsafe.Coerce as Exports++-- transformers+-------------------------+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Cont as Exports hiding (shift, callCC)+import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT, catchE, throwE)+import Control.Monad.Trans.Maybe as Exports+import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT)+import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT)+import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT)++-- text+-------------------------+import Data.Text as Exports (Text)++-- stm+-------------------------+import Control.Concurrent.STM as Exports hiding (orElse)++-- unordered-containers+-------------------------+import Data.HashSet as Exports (HashSet)+import Data.HashMap.Strict as Exports (HashMap)++-- selective+-------------------------+import Control.Selective as Exports+++mapCompose :: (f (g a) -> f' (g' a')) -> Compose f g a -> Compose f' g' a'+mapCompose fn (Compose m) = Compose (fn m)
+ library/Fx/Strings.hs view
@@ -0,0 +1,34 @@+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
+ test/Main.hs view
@@ -0,0 +1,61 @@+module Main where++import Prelude hiding (choose)+import Test.QuickCheck.Instances+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Fx+import qualified Test.QuickCheck as QuickCheck+import qualified Test.QuickCheck.Property as QuickCheck+++main = defaultMain $ testGroup "" $+  [+    testCase "Error call on main thread" $ do+      res <- try $ runFx $ error "A"+      case res of+        Left (FxException _ (ErrorCallFxExceptionReason _)) -> return ()+        Left exc -> assertFailure (show exc)+        _ -> assertFailure "Right"+    ,+    testCase "Error call on forked thread" $ do+      res <- try $ runFx $ do+        future <- start $ error "A"+        wait future+      case res of+        Left (FxException _ (ErrorCallFxExceptionReason _)) -> return ()+        Left exc -> assertFailure (show exc)+        _ -> assertFailure "Right"+    ,+    testCase "Error call on deeply forked thread" $ do+      res <- try $ runFx $ do+        future <- start $ start $ error "A"+        wait future >>= wait+      case res of+        Left (FxException _ (ErrorCallFxExceptionReason _)) -> return ()+        Left exc -> assertFailure (show exc)+        _ -> assertFailure "Right"+    ,+    testException "Fail"+      (fail "A")+      (\ case+        FxException _ (ErrorCallFxExceptionReason _) -> True+        exc -> False)+    ,+    testException "Fail on forked thread"+      (start (fail "A") >>= wait)+      (\ case+        FxException _ (ErrorCallFxExceptionReason _) -> True+        exc -> False)+  ]++testException :: TestName -> Fx () Void a -> (FxException -> Bool) -> TestTree+testException name fx validateExc = testCase name $ do+  res <- try @FxException $ runFx $ fx+  case res of+    Left exc -> if validateExc exc+      then return ()+      else assertFailure (show exc)+    Right _ -> assertFailure "No exception"