@@ -0,0 +1,262 @@
1+module Yoga.App.AppM where
5+import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, try)
6+import Control.Monad.Except (runExceptT)
7+import Control.Monad.Except.Checked (ExceptV, safe)
8+import Control.Monad.Except.Checked as ExceptV
9+import Control.Monad.Except.Trans (lift)
10+import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT(..), ask, withReaderT)
11+import Control.Monad.Reader.Trans (runReaderT)
12+import Data.Either (Either(..), either)
13+import Data.Maybe (Maybe, maybe)
14+import Data.Newtype (class Newtype, unwrap)
15+import Data.Symbol (class IsSymbol)
16+import Data.Variant (class VariantMatchCases, Variant, case_, inj, onMatch)
17+import Effect (Effect)
18+import Effect.Aff (Aff, runAff_)
19+import Effect.Aff.Class (class MonadAff, liftAff)
20+import Effect.Class (class MonadEffect)
21+import Effect.Class.Console as Console
22+import Effect.Exception (Error)
23+import Prim.Row (class Nub, class Union)
25+import Prim.RowList (class RowToList)
26+import Prim.RowList as RL
27+import Record (disjointUnion, get)
28+import Type.Prelude (Proxy(..))
29+import Unsafe.Coerce (unsafeCoerce)
31+-- | A generic type for handling computations
32+-- | It combines asynchronous side-effecting computations with `Aff`,
33+-- | "dependency injection" via `ReaderT` which tracks a context, and
34+-- | checked exceptions and early return with `ExceptV`.
35+newtype AppM ctx err a = AppM (ReaderT ctx (ExceptV err Aff) a)
39+ . VariantInjTagged r1 r2
40+ => MonadThrow (Variant r2) m
43+throw = throwError <<< injTagged
45+-- | Turns a `Nothing` into an exception which reduces nesting and encourages
46+-- | tracking what actually went wrong
50+-- | let maybeCached = Object.lookup key cache :: Maybe a
51+-- | cached :: a <- maybeCached # AppM.note (unexpectedCacheMiss key)
53+note ∷ ∀ err m a. MonadThrow err m => err -> Maybe a -> m a
54+note err = maybe (throwError $ err) pure
56+noteM ∷ ∀ err m a. MonadThrow err m => m err -> Maybe a -> m a
57+noteM err = maybe (throwError =<< err) pure
59+-- | Turns a `Left a` into an exception which reduces nesting
66+throwLeftAs toError = either (throwError <<< toError) pure
68+-- | Turn any `Aff` into an `AppM`.
69+-- | Because `Aff` can throw exceptions of type `Error`, a possible such
70+-- | exception is captured in the `exception` branch of the error variant
71+fromAff ∷ ∀ ctx a err. Aff a -> AppM ctx (exception ∷ Error | err) a
73+ AppM (lift (lift (try e)))
74+ >>= either (throw <<< { exception: _ }) pure
78+ . (Variant err1 -> AppM ctx err2 a)
81+handleErrors handle (AppM appM) = do
83+ result <- runExceptT (runReaderT appM ctx) # liftAff
85+ Left err -> handle err
89+ ∷ ∀ rl a ctx handlers excHandled excIn excOut
90+ . RowToList handlers rl
91+ => VariantMatchCases rl excHandled (AppM ctx excOut a)
92+ => Union excHandled excOut excIn
96+handleError cases (AppM appM) = do
98+ >>= (liftAff <$> unwrap <<< runReaderT appM)
99+ >>= either (onMatch cases throwError) pure
104+ -> AppM ctx err2 (ExceptV err1 Aff a)
105+toExceptV (AppM appM) = do
107+ pure $ runReaderT appM ctx
109+fromExceptV ∷ ∀ ctx err a. ExceptV err Aff a -> AppM ctx err a
110+fromExceptV = AppM <<< lift
112+-- | When you have a function that can throw a subset of the errors of the ones
113+-- | you could throw in a do block, `expand` allows to make them compatible
116+ . R.Union lt more gt
119+expand = unsafeCoerce
122+ :: forall lt more gt err
124+ => AppM { | lt } err ~>
126+expandCtx = unsafeCoerce
128+launchAppM_ ∷ ∀ ctx. ctx -> AppM ctx () Unit -> Effect Unit
129+launchAppM_ ctx appM =
131+ (either logUnhandledError pure)
134+logUnhandledError ∷ Error -> Effect Unit
135+logUnhandledError (err ∷ Error) =
137+ $ "Unhandled Error!\n"
141+ ∷ ∀ ctx r rl err_ err
143+ => VariantMatchCases rl err_ (Aff Unit)
144+ => Union err_ () err
147+ -> AppM ctx err Unit
149+launchAppM ctx errorHandlers (AppM app) =
150+ runAff_ (either logUnhandledError pure) do
151+ ExceptV.handleErrors errorHandlers $ runReaderT app ctx
153+-- | Invoke this function in the end after handling all possible errors, e.g.
155+-- | runAppM_ { token: "123" } someApp
157+runAppM_ ∷ ∀ ctx a. ctx -> AppM ctx () a -> Aff a
158+runAppM_ ctx (AppM app) = do
159+ safe $ runReaderT app ctx
161+-- | Removes the ReaderT part and makes the errors explicit
163+-- | runReader { token: "123" } someApp
165+runReader ∷ ∀ ctx err a. ctx -> AppM ctx err a -> Aff (Either (Variant err) a)
168+ $ handleErrors (pure <<< Left)
171+-- | Useful when constructing a *parameterless* callback of type `Aff` or
172+-- | `Effect` within the context of an AppM computation
174+-- | recordAndUploadDOM ∷ Aff _ <- do
175+-- | AppM.unliftAff $ serialiseDOM >>= uploadDOMSnapshot
178+ ∷ ∀ ctx err otherErrors a
180+ -> AppM ctx otherErrors (Aff (Either (Variant err) a))
183+ pure $ runReader ctx appM
185+-- | Useful when constructing a callback of type `Aff` or `Effect` within the
186+-- | context of an AppM computation
188+-- | uploadDOMDOM ∷ (SerialisedDOM -> Aff _) <- do
189+-- | AppM.unliftAffFn $ uploadDOMSnapshot
192+ ∷ ∀ ctx arg otherErrors a
193+ . (arg -> AppM ctx () a)
194+ -> AppM ctx otherErrors (arg -> Aff a)
195+unliftAffFn appM = do
198+ runReader ctx (appM arg) <#> either case_ identity
200+-- | Invoke this function in the end and handle all possible errors, e.g.
202+-- | runAppM { token: "123" } { someError: \e -> handleTheError e } someApp
205+ ∷ ∀ ctx r rl err_ err a
207+ => VariantMatchCases rl err_ (Aff a)
208+ => Union err_ () err
213+runAppM ctx errorHandlers (AppM app) = do
214+ ExceptV.handleErrors errorHandlers $ runReaderT app ctx
216+-- | Manually add some fields to the context of a computation.
217+-- | This function is useful when already inside a `do` block of an `AppM`
218+-- | and you want to call a function that requires some `ctx` that you obtained
219+-- | within this `do` block. For example:
222+-- | moreCtx <- getSomeData :: AppM {} _
223+-- | getMoreData :: AppM { moreCtx :: _ } _ # widenCtx { moreCtx }
226+ ∷ ∀ err additionalCtx ctx widerCtx
227+ . Union additionalCtx ctx widerCtx
228+ => Nub widerCtx widerCtx
229+ => { | additionalCtx }
230+ -> AppM { | widerCtx } err
231+ ~> AppM { | ctx } err
232+widenCtx toUnion (AppM (appM)) =
234+ (withReaderT (disjointUnion toUnion) appM)
236+-- Instances for the AppM type
237+derive instance Newtype (AppM ctx err a) _
238+derive newtype instance Functor (AppM ctx err)
239+derive newtype instance Applicative (AppM ctx err)
240+derive newtype instance Apply (AppM ctx err)
241+derive newtype instance Bind (AppM ctx err)
242+derive newtype instance Monad (AppM ctx err)
243+derive newtype instance MonadEffect (AppM ctx err)
244+derive newtype instance MonadAff (AppM ctx err)
245+derive newtype instance MonadAsk ctx (AppM ctx err)
246+derive newtype instance MonadReader ctx (AppM ctx err)
247+derive newtype instance MonadThrow (Variant err) (AppM ctx err)
248+derive newtype instance MonadError (Variant err) (AppM ctx err)
251+-- | Helper class to make throwing errors easier
252+class VariantInjTagged a b | a -> b where
253+ injTagged ∷ Record a -> Variant b
255+instance variantInjTagged ∷
256+ ( RowToList r1 (RL.Cons sym a RL.Nil)
257+ , R.Cons sym a () r1
258+ , R.Cons sym a rx r2
261+ VariantInjTagged r1 r2 where
262+ injTagged = inj (Proxy ∷ Proxy sym) <<< get (Proxy ∷ Proxy sym)