packages feed

lazy-async (empty) → 1.0.0.0

raw patch · 31 files changed

+1186/−0 lines, 31 filesdep +basedep +exceptionsdep +hedgehog

Dependencies added: base, exceptions, hedgehog, lazy-async, lifted-async, monad-control, optics-core, optics-th, rank2classes, stm, transformers, transformers-base

Files

+ lazy-async.cabal view
@@ -0,0 +1,115 @@+cabal-version: 3.0++name: lazy-async+version: 1.0.0.0+synopsis: Asynchronous actions that don't start right away++description:++    Sometimes we have a bunch of 'IO' actions that do things like+    read files, make HTTP requests, or query a database. Some of the+    information that these actions produce might not end up being+    needed, depending on the breaks. In the interest of avoiding+    unnecessary effort, we don't want to simply run all the actions+    and collect their results upfront. We also don't want to simply+    run an action right before its result is needed, because it might+    be needed in more than one place, which opens the possibility of+    unnecessarily running the same action more than once. In+    situations like these, we use "LazyAsync".++    Under the hood, an 'IO' action is turned into a @LazyAsync@ by+    constructing two things: An @Async@ (from the @async@ package),+    and a @TVar Bool@ (from the @stm@ package). The TVar, initialized+    to @False@, indicates whether the action is wanted yet. The async+    thread waits until the TVar turns @True@ and then runs the action.++homepage:       https://github.com/typeclasses/lazy-async+bug-reports:    https://github.com/typeclasses/lazy-async/issues+author:         Chris Martin+maintainer:     Chris Martin, Julie Moronuki+copyright:      2021 Mission Valley Software LLC+license:        MIT+license-file:   license.txt+category:       Concurrency+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/typeclasses/lazy-async++common language+    default-language:   Haskell2010+    ghc-options:        -Wall+    default-extensions: DeriveFoldable+    default-extensions: DeriveFunctor+    default-extensions: DeriveTraversable+    default-extensions: ExistentialQuantification+    default-extensions: FlexibleContexts+    default-extensions: NoImplicitPrelude+    default-extensions: StandaloneDeriving++common dependencies+    build-depends:      base              ^>= 4.14     || ^>= 4.15+    build-depends:      exceptions        ^>= 0.10.4+    build-depends:      lifted-async      ^>= 0.10.0.6+    build-depends:      monad-control     ^>= 1.0.2.3+    build-depends:      rank2classes      ^>= 1.4.0.1+    build-depends:      stm               ^>= 2.5+    build-depends:      transformers      ^>= 0.5.6.2+    build-depends:      transformers-base ^>= 0.4.5.1++common test-language+    import:             language+    default-extensions: BlockArguments+    default-extensions: OverloadedStrings+    default-extensions: TemplateHaskell++common test-dependencies+    import:             dependencies+    build-depends:      hedgehog          ^>= 1.0.4+    build-depends:      lazy-async+    build-depends:      optics-core       ^>= 0.3      || ^>= 0.4+    build-depends:      optics-th         ^>= 0.3      || ^>= 0.4++common test-modules+    other-modules:      Test.Counter+    other-modules:      Test.Exceptions+    other-modules:      Test.General+    other-modules:      Test.Optics+    other-modules:      Test.Person++common test+    import:             test-language, test-dependencies, test-modules++library+    import:             language, dependencies+    hs-source-dirs:     src+    exposed-modules:    LazyAsync+    other-modules:      LazyAsync.Actions+    other-modules:      LazyAsync.Actions.Empty+    other-modules:      LazyAsync.Actions.Memoize+    other-modules:      LazyAsync.Actions.Merge+    other-modules:      LazyAsync.Actions.Poll+    other-modules:      LazyAsync.Actions.Pure+    other-modules:      LazyAsync.Actions.Spawn+    other-modules:      LazyAsync.Actions.Start+    other-modules:      LazyAsync.Actions.StartWait+    other-modules:      LazyAsync.Actions.Wait+    other-modules:      LazyAsync.Libraries.Async+    other-modules:      LazyAsync.Libraries.Rank2+    other-modules:      LazyAsync.Orphans+    other-modules:      LazyAsync.Prelude+    other-modules:      LazyAsync.Types+    other-modules:      LazyAsync.Types.Complex+    other-modules:      LazyAsync.Types.LazyAsync+    other-modules:      LazyAsync.Types.NoAlternative+    other-modules:      LazyAsync.Types.Outcome+    other-modules:      LazyAsync.Types.Resource+    other-modules:      LazyAsync.Types.StartPoll+    other-modules:      LazyAsync.Types.Status++test-suite test+    import:             test+    hs-source-dirs:     test+    type:               exitcode-stdio-1.0+    main-is:            test.hs
+ license.txt view
@@ -0,0 +1,18 @@+Copyright 2021 Mission Valley Software LLC++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.
+ src/LazyAsync.hs view
@@ -0,0 +1,129 @@+{-# language Safe #-}++{- |++__What is this__ — A 'LazyAsync' is an action that doesn't start right away.+When it does run, it runs in a separate thread.++__How to get one__ — The 'lazyAsync' function makes a 'LazyAsync' available+within a 'ContT' context because it ensures the asynchronous action is cancelled+when the continuation ends, to avoid accidentally leaving any unneeded threads+running in the background.++__How to use it__ — You can incite a 'LazyAsync' to begin by using 🚀 'start',+and then you can use ⏸️ 'wait' to block until it completes. There is also+🚀⏸️ 'startWait', which does both.++If the only thing you ever do with your 'LazyAsync's is 'startWait' on them,+then you may consider using 'memoize' instead, which does not require+interacting with the 'LazyAsync' type at all.++-}++module LazyAsync+  ( {- * LazyAsync            -}  LazyAsync,+    {- * Spawning             -}  lazyAsync,+    {- * Getting results      -}  startWait,+    {- * Combining actions    -}  apply, choose, merge,+    {- * Catching (Outcome)   -}  startWaitCatch, Outcome (..),+                                  applyOutcome, chooseOutcome,+    {- * Polling (Status)     -}  poll, Status (..),+                                  applyStatus, chooseStatus,+    {- * Starting manually    -}  start, wait, waitCatch,+    {- * Manual cancellation  -}  acquire, Resource (..),+    {- * Transactions         -}  pollSTM, startSTM, waitCatchSTM,+    {- * Memoization          -}  memoize,+    {- * Bulk operations      -}  {- $bulk -}+                                  manyLazyAsyncs, memoizeMany, memoizeRank2,+    {- * Notes on monads      -}  {- $monads -}+    {- * Unlifted variants    -}  {- $unlifted -}+                                  withLazyAsyncIO, startWaitIO, startWaitCatchIO,+                                  pollIO, startIO, waitIO, waitCatchIO,+                                  acquireIO, withLazyAsyncListIO,+                                  withMemoizedIO, withMemoizedListIO,+    {- * Re-exports           -}  {- $re-exports -}+                                  ContT (ContT, runContT), evalContT,+                                  MonadBaseControl (liftBaseWith, restoreM, StM),+                                  MonadBase (liftBase),+                                  MonadIO (liftIO)+  ) where++import LazyAsync.Actions+import LazyAsync.Orphans ()+import LazyAsync.Prelude+import LazyAsync.Types++{- $bulk++If you have a list (or other 'Traversable') of actions, the "many" functions+('manyLazyAsyncs' and 'memoizeMany') can create a thread for each action in the+list.++If you have a big recordful of actions and feel like getting real fancy, try+making your datatype "higher-kinded" and using 'memoizeRank2' to automatically+create a bunch of threads at once. You'll need the @rank2classes@ package; see+"Rank2" and "Rank2.TH".++-}++{- $monads++__Working with ContT__ — Compose actions within the 'ContT' monadic context, and+apply 'evalContT' at the top to run the continuation. You can also apply+'runContT' to a 'ContT' action to convert it to a "continuation-passing style"+higher-order function.++__Working with MonadBaseControl and StM__ — Most of the functions in this module+are generalized using 'MonadBaseControl', which allows you to work in monads+other than 'System.IO.IO' (to see an example of this, see the test suite for+this package, which creates 'LazyAsync's in Hedgehog's @PropertyT@ context).+'StM' is a type family which often "disappears" (that is, @'StM' m a ~ a@ for+many @m@).++-}++{- $unlifted++If you are uninterested in monad transformers, you may prefer the+functions in this section.++  * All of the @m@ type variables are specialized to 'System.IO.IO',+    thus eliminating 'MonadBase', 'MonadBaseControl', 'MonadIO', and+    'StM' from the types++  * Async spawning is done with explicit continuation passing instead of+    'ContT' actions++  * 'Traversable'-constrained type constructors are specialized to @[]@++-}++{- $re-exports++Some key monad lifting concepts from other+packages are re-exported from this module.++__base__ ("Control.Monad.IO.Class")++  * 'MonadIO'+  * 'liftIO'++__transformers__  ("Control.Monad.Trans.Cont")++  * 'ContT'+  * 'runContT'+  * 'evalContT'++__monad-base__ ("Control.Monad.Base")++  * 'MonadBase'+  * 'liftBase'++__monad-control__  ("Control.Monad.Trans.Control")++  * 'MonadBaseControl'+  * 'liftBaseWith'+  * 'restoreM'+  * 'StM'++-}
+ src/LazyAsync/Actions.hs view
@@ -0,0 +1,13 @@+{-# language Safe #-}++module LazyAsync.Actions (module X) where++import LazyAsync.Actions.Empty     as X+import LazyAsync.Actions.Memoize   as X+import LazyAsync.Actions.Merge     as X+import LazyAsync.Actions.Poll      as X+import LazyAsync.Actions.Pure      as X+import LazyAsync.Actions.Spawn     as X+import LazyAsync.Actions.Start     as X+import LazyAsync.Actions.StartWait as X+import LazyAsync.Actions.Wait      as X
+ src/LazyAsync/Actions/Empty.hs view
@@ -0,0 +1,17 @@+{-# language Safe #-}++module LazyAsync.Actions.Empty where++import LazyAsync.Types (LazyAsync (..), NoAlternative (..), Outcome (..),+                        Status (..))++import LazyAsync.Prelude (toException)++emptyOutcome :: Outcome a+emptyOutcome = Failure (toException NoAlternative)++emptyStatus :: Status a+emptyStatus = Done emptyOutcome++emptyLazyAsync :: LazyAsync a+emptyLazyAsync = Empty
+ src/LazyAsync/Actions/Memoize.hs view
@@ -0,0 +1,38 @@+{-# language Safe #-}++module LazyAsync.Actions.Memoize where++import LazyAsync.Actions.Spawn     (lazyAsync)+import LazyAsync.Actions.StartWait (startWait)++import LazyAsync.Prelude (ContT, IO, MonadBaseControl, Traversable, fmap,+                          runContT, traverse)++import qualified LazyAsync.Libraries.Rank2 as Rank2++{- | Creates a situation wherein:++  * The action shall begin running only once the memoized action runs+  * The action shall run at most once+  * The action shall run only within the continuation (when the continuation ends, the action is stopped)+-}+memoize :: (MonadBaseControl IO m) =>+    m a -- ^ Action+    -> ContT r m (m a) -- ^ Memoized action, in a continuation+memoize action = fmap startWait (lazyAsync action)++-- | Akin to 'memoize'+withMemoizedIO :: IO a -> (IO a -> IO b) -> IO b+withMemoizedIO action = runContT (memoize action)++-- | 🌈 'memoizeMany' is equivalent to @('traverse' 'memoize')@+memoizeMany :: (MonadBaseControl IO m, Traversable t) => t (m a) -> ContT r m (t (m a))+memoizeMany = traverse memoize++-- | 🌈 'memoizeRank2' is equivalent to @('Rank2.traverse' 'memoize')@+memoizeRank2 :: (MonadBaseControl IO m, Rank2.Traversable t) => t m -> ContT r m (t m)+memoizeRank2 = Rank2.traverse memoize++-- | Akin to 'memoizeMany'+withMemoizedListIO :: [IO a] -> ([IO a] -> IO b) -> IO b+withMemoizedListIO x = runContT (memoizeMany x)
+ src/LazyAsync/Actions/Merge.hs view
@@ -0,0 +1,132 @@+{-# language Safe #-}++module LazyAsync.Actions.Merge where++import LazyAsync.Types (Complex (..), LazyAsync (..), Outcome (..), Status (..))++merge :: ( Status    a -> Status    b -> Status    c )+             -- ^ Status merge function+      -> ( LazyAsync a -> LazyAsync b -> LazyAsync c )+merge (*) a b = A2 (Complex (*) a b)+{- ^ A combination of two 'LazyAsync's, where the 'Status' of the+combination is a function of the statuses of each of its parts++🚀 __'LazyAsync.start'__ starts both parts immediately++The behavior of 🕵️ __'LazyAsync.poll'__ and+💣 __'LazyAsync.wait'__ is determined by the status merge function++-}++apply :: LazyAsync (a -> b) -- ^ Left part+      -> LazyAsync a        -- ^ Right part+      -> LazyAsync b        -- ^ Conjunction+apply = merge applyStatus+{- ^+Conjunctively combines the results of two 'LazyAsync's++🚀 __'LazyAsync.start'__ starts both parts immediately++⏸️ __'LazyAsync.wait'__ returns a 'LazyAsync.Success' result after both+parts complete successfully. As soon as one part fails, the whole conjunction+fails immediately (but any 'LazyAsync.Incomplete' part keeps running in the+background)++🕵️ __'LazyAsync.poll'__ returns 'LazyAsync.Failure' if either part has failed;+otherwise 'LazyAsync.Incomplete' if either part has not finished; otherwise+'LazyAsync.Success'++💣 The 'LazyAsync.wait' and 'LazyAsync.poll' operations disclose the+leftmost exception of the parts that have failed so far, which may not+be consistent over time++🌈 'apply' is equivalent to @('merge' 'applyStatus')@+-}++choose :: LazyAsync a -- ^ Left part+       -> LazyAsync a -- ^ Right part+       -> LazyAsync a -- ^ Disjunction+choose = merge chooseStatus+{- ^+Disjunctively combines the results of two 'LazyAsync's++🚀 __'LazyAsync.start'__ starts both parts immediately++⏸️ __'LazyAsync.wait'__ returns a 'LazyAsync.Success' result after either part+completes successfully. As soon as one part succeeds, the whole disjunction+succeeds immediately (but any 'LazyAsync.Incomplete' part keeps running in the+background)++🕵️ __'LazyAsync.poll'__ returns 'LazyAsync.Success' if either part has+succeeded; otherwise 'LazyAsync.Incomplete' if either part has not finished;+otherwise 'LazyAsync.Failure'++✅ The 'LazyAsync.wait' and 'LazyAsync.poll' operations disclose the leftmost+result of the parts that have succeeded so far, which may not be consistent+over time++🌈 'choose' is equivalent to @('merge' 'chooseStatus')@+-}++{- | Combines two 'LazyAsync.LazyAsync' statuses to produce the status of their+conjunction++💣 Returns the leftmost 'Failure', if there is one++⏳ Otherwise, if any part of a conjunction is 'Incomplete', then the whole thing+evaluates to 'Incomplete'++✅ Only when all parts have completed as 'Success' does the whole succeed++For example, @'applyStatus' 'Incomplete' ('Failure' e)@ = @'Failure' e@ -}+applyStatus :: Status (a -> b) -> Status a -> Status b+applyStatus a b =+    case a of+        Done (Success f) ->+            case b of+                Done (Success x) -> Done (Success (f x))+                Done (Failure e) -> Done (Failure e)+                Incomplete       -> Incomplete+        Done (Failure e) -> Done (Failure e)+        Incomplete ->+            case b of+                Done (Failure e) -> Done (Failure e)+                _                -> Incomplete++{- | Combines two 'LazyAsync.LazyAsync' statuses to produce the status of their+disjunction++✅ Returns the leftmost 'Success', if there is one++⏳ Otherwise, if any part of a disjunction is 'Incomplete', then the whole thing+evaluates to 'Incomplete'++💣 Only when all parts have completed as 'Failure' does the whole fail -}+chooseStatus :: Status a -> Status a -> Status a+chooseStatus x y =+    case x of+        Done Success{} -> x+        Done Failure{} -> y+        Incomplete ->+            case y of+                Done Failure{} -> x+                _              -> y++-- | Behaves the same as 'Control.Applicative.<*>' for+-- 'Data.Either.Either', halting at the leftmost 'Failure'+applyOutcome :: Outcome (a -> b) -> Outcome a -> Outcome b+applyOutcome fo ao =+    case fo of+        Failure e -> Failure e+        Success f ->+            case ao of+                Failure e -> Failure e+                Success x -> Success (f x)++-- | Behaves the same as 'Control.Applicative.<|>' for+-- 'Data.Either.Either', returning the leftmost 'Success'+chooseOutcome :: Outcome a -> Outcome a -> Outcome a+chooseOutcome x y =+    case x of+        Failure{} -> y+        _         -> x
+ src/LazyAsync/Actions/Poll.hs view
@@ -0,0 +1,29 @@+{-# language Safe #-}++module LazyAsync.Actions.Poll where++import LazyAsync.Actions.Empty (emptyStatus)+import LazyAsync.Actions.Pure  (pureStatus)+import LazyAsync.Types         (Complex (..), LazyAsync (..), StartPoll (..),+                                Status (..))++import LazyAsync.Prelude (IO, MonadBaseControl, MonadIO, STM, StM, atomically,+                          fmap, liftA2, liftBase, liftIO, restoreM, return,+                          sequenceA, (=<<))++-- | 🕵️ Checks whether an asynchronous action has completed yet+--+-- 🛑 Does not start the action+poll :: (MonadBaseControl base m, MonadIO base) => LazyAsync (StM m a) -> m (Status a)+poll la = sequenceA =<< liftBase (fmap (fmap restoreM) (liftIO (pollIO la)))++-- | Akin to 'poll'+pollIO :: LazyAsync a -> IO (Status a)+pollIO la = atomically (pollSTM la)++-- | Akin to 'poll'+pollSTM :: LazyAsync a -> STM (Status a)+pollSTM (Pure x)             = return (pureStatus x)+pollSTM (A1 (StartPoll _ a)) = a+pollSTM (A2 (Complex o x y)) = liftA2 (o) (pollSTM x) (pollSTM y)+pollSTM Empty                = return emptyStatus
+ src/LazyAsync/Actions/Pure.hs view
@@ -0,0 +1,14 @@+{-# language Safe #-}++module LazyAsync.Actions.Pure where++import LazyAsync.Types (LazyAsync (..), Outcome (..), Status (..))++pureOutcome :: a -> Outcome a+pureOutcome = Success++pureStatus :: a -> Status a+pureStatus x = Done (pureOutcome x)++pureLazyAsync :: a -> LazyAsync a+pureLazyAsync = Pure
+ src/LazyAsync/Actions/Spawn.hs view
@@ -0,0 +1,102 @@+{-# language Safe #-}++module LazyAsync.Actions.Spawn+  ( lazyAsync, withLazyAsyncIO+  , manyLazyAsyncs, withLazyAsyncListIO+  , acquire, acquireIO+  ) where++import LazyAsync.Libraries.Async (Async, async, cancel, pollSTM, withAsync)++import LazyAsync.Types (LazyAsync (A1), Outcome (..), Resource (..),+                        StartPoll (..), Status (..))++import LazyAsync.Prelude (Applicative ((*>)), Bool (..), ContT (..),+                          Either (..), Functor (fmap), IO, Maybe (..),+                          MonadBase (..), MonadBaseControl (StM), MonadIO (..),+                          SomeException, TVar, Traversable, atomically, check,+                          lift, newTVarIO, readTVar, return, traverse,+                          writeTVar, (<&>), (>>=))++startPoll :: MonadBaseControl IO m =>+    m a -- ^ Action+    -> ContT b m (StartPoll (StM m a))+startPoll action =+  do+    s <- lift (newTVar False)+    a <- ContT (withAsync (waitForTrue s *> action))+    return (makeStartPoll s a)++acquireStartPoll :: MonadBaseControl IO m =>+    m a -- ^ Action+    -> m (Resource m (StartPoll (StM m a)))+acquireStartPoll action =+  do+    s <- newTVar False+    a <- async (waitForTrue s *> action)+    return (Resource{ release = cancel a, resource = makeStartPoll s a})++makeStartPoll :: TVar Bool -> Async a -> StartPoll a+makeStartPoll s a = StartPoll (writeTVar s True) (pollSTM a <&> maybeEitherStatus)++{- | Creates a situation wherein:++  * The action shall begin running only once it is needed (that is, until prompted by 'LazyAsync.start')+  * The action shall run asynchronously (other than where it is 'LazyAsync.wait'ed upon)+  * The action shall run at most once+  * The action shall run only within the continuation (when the continuation ends, the action is stopped)+-}+lazyAsync :: MonadBaseControl IO m =>+    m a -- ^ Action+    -> ContT r m (LazyAsync (StM m a))+lazyAsync action = fmap A1 (startPoll action)++-- | 🌈 'manyLazyAsyncs' is equivalent to @('traverse' 'lazyAsync')@+manyLazyAsyncs :: (MonadBaseControl IO m, Traversable t) =>+    t (m a) -> ContT r m (t (LazyAsync (StM m a)))+manyLazyAsyncs = traverse lazyAsync++-- | Akin to 'manyLazyAsyncs'+withLazyAsyncListIO :: [IO a] -> ([LazyAsync a] -> IO b) -> IO b+withLazyAsyncListIO actions = runContT (manyLazyAsyncs actions)++{- | Like 'lazyAsync', but does not automatically stop the action++The returned 'Resource' includes the desired 'LazyAsync' (the 'resource'), as+well as a 'release' action that brings it to a halt. If the action is not yet+started, 'release' prevents it from ever starting. If the action is in progress,+'release' throws an async exception to stop it. If the action is completed,+'release' has no effect.++A 'LazyAsync.LazyAsync' represents a background thread which may be utilizing+time and space. A running thread is not automatically reaped by the garbage+collector, so one should take care to eventually 'release' every 'LazyAsync'+resource to avoid accidentally leaving unwanted 'LazyAsync's running.++-}+acquire :: MonadBaseControl IO m =>+    m a -- ^ Action+    -> m (Resource m (LazyAsync (StM m a)))+acquire action = fmap (fmap A1) (acquireStartPoll action)++-- | Akin to 'acquire'+acquireIO :: IO a -> IO (Resource IO (LazyAsync a))+acquireIO = acquire++-- | Akin to 'lazyAsync'+withLazyAsyncIO :: IO a -> (LazyAsync a -> IO b) -> IO b+withLazyAsyncIO action = runContT (lazyAsync action)++waitForTrue :: (MonadBase base m, MonadIO base) => TVar Bool -> m ()+waitForTrue x = liftBase (liftIO (atomically (readTVar x >>= check)))++newTVar :: (MonadBase base m, MonadIO base) => a -> m (TVar a)+newTVar x = liftBase (liftIO (newTVarIO x))++maybeEitherStatus :: Maybe (Either SomeException a) -> Status a+maybeEitherStatus Nothing  = Incomplete+maybeEitherStatus (Just x) = Done (eitherDone x)++eitherDone :: Either SomeException a -> Outcome a+eitherDone (Left e)  = Failure e+eitherDone (Right x) = Success x
+ src/LazyAsync/Actions/Start.hs view
@@ -0,0 +1,26 @@+{-# language Safe #-}++module LazyAsync.Actions.Start where++import LazyAsync.Types (Complex (..), LazyAsync (..), StartPoll (..))++import LazyAsync.Prelude (Applicative ((*>)), IO, MonadBase (..), MonadIO (..),+                          STM, atomically, return)++-- | 🚀 Starts an asynchronous action, if it has not already been started+start :: (MonadBase base m, MonadIO base) => LazyAsync a -> m ()+start Pure{}               = return ()+start Empty{}              = return ()+start (A1 (StartPoll s _)) = liftBase (liftIO (atomically s))+start (A2 (Complex _ x y)) = start x *> start y++-- | Akin to 'start'+startIO :: LazyAsync a -> IO ()+startIO = start++-- | Akin to 'start'+startSTM :: LazyAsync a -> STM ()+startSTM Pure{}               = return ()+startSTM Empty{}              = return ()+startSTM (A1 (StartPoll s _)) = s+startSTM (A2 (Complex _ x y)) = startSTM x *> startSTM y
+ src/LazyAsync/Actions/StartWait.hs view
@@ -0,0 +1,39 @@+{-# language Safe #-}++module LazyAsync.Actions.StartWait where++import LazyAsync.Actions.Start (start)+import LazyAsync.Actions.Wait  (wait, waitCatch)++import LazyAsync.Types (LazyAsync, Outcome)++import LazyAsync.Prelude (Applicative ((*>)), IO, MonadBaseControl (StM),+                          MonadIO)++-- | 🚀 Starts an asynchronous action,+-- ⏸️ waits for it to complete, and+-- ✅ returns its value+--+-- 💣 If the action throws an exception, then the exception is re-thrown+--+-- 🌈 @('startWait' x)@ is equivalent to @('start' x '*>' 'wait' x)@+startWait :: (MonadBaseControl base m, MonadIO base) => LazyAsync (StM m a) -> m a+startWait x = start x *> wait x++-- | Akin to 'startWait'+startWaitIO :: LazyAsync a -> IO a+startWaitIO = startWait++-- | 🚀 Starts an asynchronous action,+-- ⏸️ waits for it to complete, and+-- ✅ returns its value+--+-- 💣 If the action throws an exception, then the exception is returned+--+-- 🌈 @('startWaitCatch' x)@ is equivalent to @('start' x '*>' 'waitCatch' x)@+startWaitCatch :: (MonadBaseControl base m, MonadIO base) => LazyAsync (StM m a) -> m (Outcome a)+startWaitCatch x = start x *> waitCatch x++-- | Akin to 'startWaitCatch'+startWaitCatchIO :: LazyAsync a -> IO (Outcome a)+startWaitCatchIO = startWaitCatch
+ src/LazyAsync/Actions/Wait.hs view
@@ -0,0 +1,48 @@+{-# language Safe #-}++module LazyAsync.Actions.Wait where++import LazyAsync.Actions.Poll (pollSTM)++import LazyAsync.Types (LazyAsync, Outcome (..), Status (..))++import LazyAsync.Prelude (Functor (fmap), IO, MonadBase (liftBase),+                          MonadBaseControl (..), MonadIO (..), MonadThrow (..),+                          STM, Traversable (sequenceA), atomically, retry,+                          return, (=<<), (>=>), (>>=))++-- | Akin to 'waitCatch'+waitCatchSTM :: LazyAsync a -> STM (Outcome a)+waitCatchSTM = pollSTM >=> statusOutcomeSTM++-- | ⏸️ Waits for the action to complete and ✅ returns its value+--+-- 💣 If the action throws an exception, then the exception is returned+--+-- 🛑 Does not start the action+waitCatch :: (MonadBaseControl base m, MonadIO base) => LazyAsync (StM m a) -> m (Outcome a)+waitCatch x = sequenceA =<< liftBase (fmap (fmap restoreM) (liftIO (waitCatchIO x)))++-- | Akin to 'waitCatch'+waitCatchIO :: LazyAsync a -> IO (Outcome a)+waitCatchIO la = atomically (waitCatchSTM la)++-- | ⏸️ Waits for the action to complete and ✅ returns its value+--+-- 💣 If the action throws an exception, then the exception is re-thrown+--+-- 🛑 Does not start the action+wait :: (MonadBaseControl base m, MonadIO base) => LazyAsync (StM m a) -> m a+wait x = liftBase (liftIO (waitCatchIO x) >>= (\o -> liftIO (outcomeSuccess o))) >>= restoreM++-- | Akin to 'wait'+waitIO :: LazyAsync a -> IO a+waitIO = wait++statusOutcomeSTM :: Status a -> STM (Outcome a)+statusOutcomeSTM Incomplete = retry+statusOutcomeSTM (Done x)   = return x++outcomeSuccess :: MonadThrow m => Outcome a -> m a+outcomeSuccess (Failure e) = throwM e+outcomeSuccess (Success x) = return x
+ src/LazyAsync/Libraries/Async.hs view
@@ -0,0 +1,8 @@+{-# language Trustworthy #-}++module LazyAsync.Libraries.Async (Async, pollSTM, withAsync, async, cancel, Forall, Pure) where++import Control.Concurrent.Async.Lifted (Async, async, cancel, pollSTM,+                                        withAsync)++import Control.Concurrent.Async.Lifted.Safe (Forall, Pure)
+ src/LazyAsync/Libraries/Rank2.hs view
@@ -0,0 +1,5 @@+{-# language Trustworthy #-}++module LazyAsync.Libraries.Rank2 (Traversable (traverse)) where++import Rank2
+ src/LazyAsync/Orphans.hs view
@@ -0,0 +1,39 @@+{-# language Safe #-}++{-# options_ghc -Wno-orphans #-}++module LazyAsync.Orphans where++import LazyAsync.Actions+import LazyAsync.Prelude+import LazyAsync.Types++-- | 🌈 '<*>' is equivalent to 'LazyAsync.apply'+instance Applicative LazyAsync where+    pure = pureLazyAsync+    (<*>) = apply++-- | 🌈 '<|>' is equivalent to 'LazyAsync.choose'+instance Alternative LazyAsync where+    empty = emptyLazyAsync+    (<|>) = choose++-- | 🌈 '<*>' is equivalent to 'applyStatus'+instance Applicative Status where+    pure = pureStatus+    (<*>) = applyStatus++-- | 🌈 '<|>' is equivalent to 'chooseStatus'+instance Alternative Status where+    empty = emptyStatus+    (<|>) = chooseStatus++-- | 🌈 '<*>' is equivalent to 'applyOutcome'+instance Applicative Outcome where+    pure = pureOutcome+    (<*>) = applyOutcome++-- | 🌈 '<|>' is equivalent to 'chooseOutcome'+instance Alternative Outcome where+    empty = emptyOutcome+    (<|>) = chooseOutcome
+ src/LazyAsync/Prelude.hs view
@@ -0,0 +1,28 @@+{-# language Safe #-}++module LazyAsync.Prelude (module X) where++import Control.Exception as X (Exception, SomeException, toException)+import Data.Bool         as X (Bool (..))+import Data.Either       as X (Either (..))+import Data.Foldable     as X (Foldable)+import Data.Functor      as X (Functor, fmap, (<&>))+import Data.Maybe        as X (Maybe (..))+import Data.Traversable  as X (Traversable, sequenceA, traverse)+import System.IO         as X (IO)+import Text.Show         as X (Show)++import Control.Applicative as X (Alternative (empty, (<|>)),+                                 Applicative (pure, (<*>)), empty, liftA2, pure,+                                 (*>), (<*>), (<|>))++import Control.Concurrent.STM      as X (STM, atomically, check, retry)+import Control.Concurrent.STM.TVar as X (TVar, newTVarIO, readTVar, writeTVar)++import Control.Monad               as X (return, (=<<), (>=>), (>>=))+import Control.Monad.Base          as X (MonadBase, liftBase)+import Control.Monad.Catch         as X (MonadThrow, throwM)+import Control.Monad.IO.Class      as X (MonadIO, liftIO)+import Control.Monad.Trans.Class   as X (lift)+import Control.Monad.Trans.Cont    as X (ContT (ContT), evalContT, runContT)+import Control.Monad.Trans.Control as X (MonadBaseControl (StM, liftBaseWith, restoreM))
+ src/LazyAsync/Types.hs view
@@ -0,0 +1,11 @@+{-# language Safe #-}++module LazyAsync.Types (module X) where++import LazyAsync.Types.Complex       as X+import LazyAsync.Types.LazyAsync     as X+import LazyAsync.Types.NoAlternative as X+import LazyAsync.Types.Outcome       as X+import LazyAsync.Types.Resource      as X+import LazyAsync.Types.StartPoll     as X+import LazyAsync.Types.Status        as X
+ src/LazyAsync/Types/Complex.hs view
@@ -0,0 +1,9 @@+{-# language Safe #-}++module LazyAsync.Types.Complex where++import LazyAsync.Prelude (Functor)++data Complex f g a = forall x y. Complex (g x -> g y -> g a) (f x) (f y)++deriving instance Functor g => Functor (Complex f g)
+ src/LazyAsync/Types/LazyAsync.hs view
@@ -0,0 +1,17 @@+{-# language Safe #-}++module LazyAsync.Types.LazyAsync where++import LazyAsync.Types.Complex   (Complex (..))+import LazyAsync.Types.StartPoll (StartPoll)+import LazyAsync.Types.Status    (Status)++import LazyAsync.Prelude (Functor)++-- | An asynchronous action that does not start right away+data LazyAsync a =+    Empty -- ^ Triviality that gives rise to 'Control.Applicative.empty'+  | Pure a -- ^ Triviality that gives rise to 'Control.Applicative.pure'+  | A1 (StartPoll a) -- ^ A single action+  | A2 (Complex LazyAsync Status a) -- ^ A complex of two 'LazyAsync's+  deriving Functor
+ src/LazyAsync/Types/NoAlternative.hs view
@@ -0,0 +1,9 @@+{-# language Safe #-}++module LazyAsync.Types.NoAlternative where++import LazyAsync.Prelude (Exception, Show)++data NoAlternative = NoAlternative deriving Show++instance Exception NoAlternative
+ src/LazyAsync/Types/Outcome.hs view
@@ -0,0 +1,13 @@+{-# language Safe #-}++module LazyAsync.Types.Outcome where++import LazyAsync.Prelude (Foldable, Functor, Show, SomeException, Traversable)++-- | The result of a 'LazyAsync.LazyAsync' that is 'LazyAsync.Done' running+--+-- Obtained using 'LazyAsync.waitCatch'+data Outcome a =+    Failure SomeException -- ^ 💣 The 'LazyAsync.LazyAsync.LazyAsync' action threw an exception+  | Success a -- ^ ✅ The 'LazyAsync.LazyAsync.LazyAsync' action completed normally+    deriving (Foldable, Functor, Show, Traversable)
+ src/LazyAsync/Types/Resource.hs view
@@ -0,0 +1,15 @@+{-# language Safe #-}++module LazyAsync.Types.Resource where++import LazyAsync.Prelude (Functor)++{- | A resource and an action that releases it++A /resource/ is something that can be /acquired/ and then /released/, where+releasing an object once it is no longer needed is important because the supply+is exhaustible.++-}+data Resource m a = Resource{ release :: m (), resource :: a }+    deriving Functor
+ src/LazyAsync/Types/StartPoll.hs view
@@ -0,0 +1,12 @@+{-# language Safe #-}++module LazyAsync.Types.StartPoll where++import LazyAsync.Types.Status (Status)++import LazyAsync.Prelude (Functor, STM)++data StartPoll a = StartPoll+    (STM ()) -- ^ Start+    (STM (Status a)) -- ^ Poll+  deriving Functor
+ src/LazyAsync/Types/Status.hs view
@@ -0,0 +1,20 @@+{-# language Safe #-}++module LazyAsync.Types.Status where++import LazyAsync.Types.Outcome (Outcome)++import LazyAsync.Prelude (Foldable, Functor, Show, Traversable)++-- | Whether a 'LazyAsync.LazyAsync' action has+-- completed yet, and, if so, what it produced+--+-- Obtained using 'LazyAsync.poll'+data Status a =+    Incomplete -- ^ ⏳+        -- The 'LazyAsync.LazyAsync' action has not finished+        -- (and might not have even started yet)+  | Done (Outcome a) -- ^ ⌛+        -- The 'LazyAsync.LazyAsync' action has ended, either+        -- by ✅ returning normally or by 💣 throwing an exception+    deriving (Foldable, Functor, Show, Traversable)
+ test/Test/Counter.hs view
@@ -0,0 +1,40 @@+module Test.Counter (expectTicks) where++import Data.Function   (($))+import Hedgehog        (MonadTest, (===))+import Numeric.Natural (Natural)+import Prelude         (($!), (+))+import System.IO       (IO)++import Control.Monad            (return)+import Control.Monad.Base       (MonadBase, liftBase)+import Control.Monad.IO.Class   (MonadIO, liftIO)+import Control.Monad.Trans.Cont (ContT (ContT))++import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar,+                               readTVarIO, writeTVar)++type Counter = TVar Natural++newCounter :: MonadBase IO m => m Counter+newCounter = liftBase $ newTVarIO 0++tickCounter :: MonadIO m => Counter -> m Natural+tickCounter counter = liftIO $ atomically $ do+    x <- readTVar counter+    _ <- writeTVar counter $! x + 1+    return $ x + 1++assertCount :: (MonadBase IO m, MonadTest m) => Counter -> Natural -> m ()+assertCount counter expected = do+    x <- liftBase $ readTVarIO counter+    x === expected++expectTicks :: (MonadBase IO m, MonadTest m, MonadIO m') =>+    Natural -- ^ Expected number of times the 'Tick' action runs+    -> ContT r m (m' Natural)+expectTicks n = ContT $ \run -> do+    counter <- newCounter+    x <- run $ tickCounter counter+    assertCount counter n+    return x
+ test/Test/Exceptions.hs view
@@ -0,0 +1,15 @@+module Test.Exceptions where++import Data.Eq    (Eq)+import Data.Maybe (Maybe (Just))+import Hedgehog   (MonadTest, (===))+import Prelude    (Integer)+import Text.Show  (Show)++import Control.Exception (Exception, SomeException, fromException, throw)++throw' :: Exception e => e -> m Integer+throw' = throw++exceptionIs :: MonadTest m => (Exception e, Eq e, Show e) => e -> SomeException -> m ()+exceptionIs a b = Just a === fromException b
+ test/Test/General.hs view
@@ -0,0 +1,28 @@+module Test.General where++import Control.Concurrent       (threadDelay)+import Control.Monad            (when, (>>=))+import Control.Monad.Base       (MonadBase, liftBase)+import Control.Monad.IO.Class   (MonadIO, liftIO)+import Control.Monad.Trans.Cont (ContT, evalContT)+import Data.Bool                (not)+import Data.Function            ((.))+import System.Exit              (exitFailure)+import System.IO                (IO)++import Hedgehog (Group, Property, PropertyT, checkParallel, property, withTests)++main' :: Group -> IO ()+main' group = checkParallel group >>= \ok -> when (not ok) exitFailure++example :: PropertyT IO () -> Property+example = withTests 1 . property++contExample :: ContT () (PropertyT IO) () -> Property+contExample = example . evalContT++contIO :: MonadIO m => ContT a IO a -> ContT () m a+contIO = liftIO . evalContT++pause :: MonadBase IO m => m ()+pause = liftBase (threadDelay 1000000)
+ test/Test/Optics.hs view
@@ -0,0 +1,16 @@+module Test.Optics (focus, _Incomplete, _Failure, _Success, _Done) where++import Control.Monad     (Monad (return))+import Data.Function     ((.))+import Data.Maybe        (maybe)+import Hedgehog          (MonadTest, failure)+import LazyAsync         (Outcome, Status)+import Optics.AffineFold (An_AffineFold, preview)+import Optics.Optic      (Is, Optic')+import Optics.TH         (makePrisms)++$(makePrisms ''Status)+$(makePrisms ''Outcome)++focus :: (MonadTest m, Is k An_AffineFold) => Optic' k is s a -> s -> m a+focus o = maybe failure return . preview o
+ test/Test/Person.hs view
@@ -0,0 +1,28 @@+{- |++"Higher-kinded datatypes", for tests+involving functions like 'memoizeRank2'++-}++module Test.Person where++import Data.String     (String)+import Numeric.Natural (Natural)+import Rank2.TH        (deriveAll)++data Person f =+  Person+    { name     :: f String+    , age      :: f Natural+    , location :: Location f+    }++data Location f =+  Location+    { city  :: f String+    , state :: f String+    }++$(deriveAll ''Location)+$(deriveAll ''Person)
+ test/test.hs view
@@ -0,0 +1,153 @@+module Main (main) where++import LazyAsync++import Test.Counter+import Test.Exceptions+import Test.General+import Test.Optics+import Test.Person++import Data.Foldable (traverse_)+import Data.Function (($), (.))+import Data.Functor  (($>))+import Prelude       (Integer, (+))+import System.IO     (IO)++import Control.Exception (ArithException (DivideByZero))++import Control.Applicative       (liftA2, (<|>))+import Control.Monad             (replicateM_, return, (>>=))+import Control.Monad.Trans.Class (MonadTrans (lift))++import Hedgehog (Property, annotate, discover, (===))++main :: IO ()+main = main' $$(discover)++prop_noAutoStart :: Property+prop_noAutoStart = contExample do+    annotate "'LazyAsync' does not start automatically"+    tick <- expectTicks 0+    la <- lazyAsync tick+    pause+    lift (poll la) >>= focus _Incomplete++prop_memoize_noAutoStart :: Property+prop_memoize_noAutoStart = contExample do+    annotate "'memoize' does not start the action"+    tick <- expectTicks 0+    _ <- memoize tick+    pause++prop_start :: Property+prop_start = contExample do+    annotate "'start' prompts a 'LazyAsync' to run"+    tick <- expectTicks 1+    la <- lazyAsync tick+    start la+    pause++prop_startWait :: Property+prop_startWait = contExample do+    annotate "'startWait' prompts a 'LazyAsync' to run"+    tick <- expectTicks 1+    la <- lazyAsync tick+    lift (startWait la >>= (=== 1))++prop_start_idempotent :: Property+prop_start_idempotent = contExample do+    annotate "'start' is idempotent"+    tick <- expectTicks 1+    la <- lazyAsync tick+    replicateM_ 2 (start la)+    pause++prop_startWait_idempotent :: Property+prop_startWait_idempotent = contExample do+    annotate "'startWait' is idemponent"+    tick <- expectTicks 1+    la <- lazyAsync tick+    lift (replicateM_ 2 (startWait la >>= (=== 1)))++prop_memoize_idempotent :: Property+prop_memoize_idempotent = contExample do+    annotate "The action returned by 'memoize' is idempotent"+    tick <- expectTicks 1+    tick' <- memoize tick+    lift (replicateM_ 2 (tick' >>= (=== 1)))++prop_startWaitCatch :: Property+prop_startWaitCatch = contExample do+    annotate "'startWaitCatch' catches exceptions"+    la <- lazyAsync (throw' DivideByZero)+    lift (startWaitCatch la) >>= focus _Failure >>= exceptionIs DivideByZero++prop_startWaitCatch_idempotent :: Property+prop_startWaitCatch_idempotent = contExample do+    annotate "'startWaitCatch' is idempotent"+    tick <- expectTicks 1+    la <- lazyAsync tick+    replicateM_ 2 (lift (startWaitCatch la))++prop_apply_startWait_both :: Property+prop_apply_startWait_both = contExample do+    annotate "'startWait' on an applicative complex runs both actions"+    tick <- expectTicks 2++    outcome <- contIO do+        la1 <- lazyAsync tick+        la2 <- lazyAsync tick+        let complex = liftA2 (+) la1 la2+        lift (startWaitCatch complex)++    lift (focus _Success outcome >>= (=== 3))++prop_apply_once :: Property+prop_apply_once = contExample do+    annotate "actions included in multiple applicative complexes still can only run once"+    tick <- expectTicks 3++    contIO do+        la1 <- lazyAsync tick+        la2 <- lazyAsync tick+        la3 <- lazyAsync tick++        let complexes = [ liftA2 (,) la1 la2+                        , liftA2 (,) la3 la2+                        , liftA2 (,) la1 la3 ]++        traverse_ start complexes+        lift (traverse_ wait complexes)++prop_choose :: Property+prop_choose = contExample do+    annotate "(<|>) can tolerate the failure of either part"+    la1 <- lazyAsync (return (5 :: Integer))+    la2 <- lazyAsync (throw' DivideByZero)++    let complex1 = la1 <|> la2+        complex2 = la2 <|> la1++    lift do+        startWait complex1 >>= (=== 5)+        startWait complex2 >>= (=== 5)++prop_rank2 :: Property+prop_rank2 = contExample do+    annotate "memoizeRank2 separately memoizes each field of a higher-kinded datatype"+    tick <- expectTicks 2++    person <- memoizeRank2+        Person+            { name = tick $> "Chris"+            , age  = tick $> 34+            , location =+                Location+                  { city  = tick $> "Ronan"+                  , state = tick $> "Montana"+                  }+            }++    lift $ name person               >>= (=== "Chris")+    lift $ (state . location) person >>= (=== "Montana")