fx 0.10.1 → 0.11

raw patch · 14 files changed

+919/−155 lines, 14 filesdep +fxdep +hspecdep +monad-parallelsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: fx, hspec, monad-parallel, mtl, rerebase, stm, text, transformers

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Setup.hs +0/−2
• fx.cabal +109/−42
• library/Fx.hs +57/−0
• library/Fx/Conc.hs +74/−0
• library/Fx/EitherEffect.hs +0/−47
• library/Fx/EitherEffect/Types.hs +0/−13
• library/Fx/Future.hs +117/−0
• library/Fx/Fx.hs +301/−0
• library/Fx/Prelude.hs +38/−25
• library/Fx/Scope.hs +97/−0
• library/Fx/Strings.hs +32/−0
• library/Fx/Transform.hs +0/−25
• test/Main.hs +93/−0

@@ -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

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -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 <nikita.y.volkov@mail.ru>-maintainer:-  Nikita Volkov <nikita.y.volkov@mail.ru>-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 <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+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,

@@ -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)

@@ -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

@@ -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)

@@ -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)

@@ -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 ())

@@ -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)

@@ -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)

@@ -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)

@@ -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

@@ -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)

@@ -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"