@@ -0,0 +1,262 @@
1+module Yoga.App.AppM where
2+
3+import Prelude
4+
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)
24+import Prim.Row as R
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)
30+
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)
36+
37+throw
38+ ∷ ∀ m r1 r2 a
39+ . VariantInjTagged r1 r2
40+ => MonadThrow (Variant r2) m
41+ => Record r1
42+ -> m a
43+throw = throwError <<< injTagged
44+
45+-- | Turns a `Nothing` into an exception which reduces nesting and encourages
46+-- | tracking what actually went wrong
47+-- | e.g.
48+-- | ```purescript
49+-- | do
50+-- | let maybeCached = Object.lookup key cache :: Maybe a
51+-- | cached :: a <- maybeCached # AppM.note (unexpectedCacheMiss key)
52+-- | ```
53+note ∷ ∀ err m a. MonadThrow err m => err -> Maybe a -> m a
54+note err = maybe (throwError $ err) pure
55+
56+noteM ∷ ∀ err m a. MonadThrow err m => m err -> Maybe a -> m a
57+noteM err = maybe (throwError =<< err) pure
58+
59+-- | Turns a `Left a` into an exception which reduces nesting
60+throwLeftAs
61+ ∷ ∀ err m left right
62+ . MonadThrow err m
63+ => (left -> err)
64+ -> Either left right
65+ -> m right
66+throwLeftAs toError = either (throwError <<< toError) pure
67+
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
72+fromAff e =
73+ AppM (lift (lift (try e)))
74+ >>= either (throw <<< { exception: _ }) pure
75+
76+handleErrors
77+ ∷ ∀ ctx err1 err2 a
78+ . (Variant err1 -> AppM ctx err2 a)
79+ -> AppM ctx err1 a
80+ -> AppM ctx err2 a
81+handleErrors handle (AppM appM) = do
82+ ctx <- ask
83+ result <- runExceptT (runReaderT appM ctx) # liftAff
84+ case result of
85+ Left err -> handle err
86+ Right r -> pure r
87+
88+handleError
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
93+ => Record handlers
94+ -> AppM ctx excIn a
95+ -> AppM ctx excOut a
96+handleError cases (AppM appM) = do
97+ ask
98+ >>= (liftAff <$> unwrap <<< runReaderT appM)
99+ >>= either (onMatch cases throwError) pure
100+
101+toExceptV
102+ ∷ ∀ ctx err1 err2 a
103+ . AppM ctx err1 a
104+ -> AppM ctx err2 (ExceptV err1 Aff a)
105+toExceptV (AppM appM) = do
106+ ctx <- ask
107+ pure $ runReaderT appM ctx
108+
109+fromExceptV ∷ ∀ ctx err a. ExceptV err Aff a -> AppM ctx err a
110+fromExceptV = AppM <<< lift
111+
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
114+expand
115+ ∷ ∀ ctx lt more gt
116+ . R.Union lt more gt
117+ => AppM ctx lt
118+ ~> AppM ctx gt
119+expand = unsafeCoerce
120+
121+expandCtx
122+ :: forall lt more gt err
123+ . Union lt more gt
124+ => AppM { | lt } err ~>
125+ AppM { | gt } err
126+expandCtx = unsafeCoerce
127+
128+launchAppM_ ∷ ∀ ctx. ctx -> AppM ctx () Unit -> Effect Unit
129+launchAppM_ ctx appM =
130+ runAff_
131+ (either logUnhandledError pure)
132+ (runAppM_ ctx appM)
133+
134+logUnhandledError ∷ Error -> Effect Unit
135+logUnhandledError (err ∷ Error) =
136+ Console.error
137+ $ "Unhandled Error!\n"
138+ <> show err
139+
140+launchAppM
141+ ∷ ∀ ctx r rl err_ err
142+ . RowToList r rl
143+ => VariantMatchCases rl err_ (Aff Unit)
144+ => Union err_ () err
145+ => ctx
146+ -> Record r
147+ -> AppM ctx err Unit
148+ -> Effect Unit
149+launchAppM ctx errorHandlers (AppM app) =
150+ runAff_ (either logUnhandledError pure) do
151+ ExceptV.handleErrors errorHandlers $ runReaderT app ctx
152+
153+-- | Invoke this function in the end after handling all possible errors, e.g.
154+-- | ```purescript
155+-- | runAppM_ { token: "123" } someApp
156+-- | ```
157+runAppM_ ∷ ∀ ctx a. ctx -> AppM ctx () a -> Aff a
158+runAppM_ ctx (AppM app) = do
159+ safe $ runReaderT app ctx
160+
161+-- | Removes the ReaderT part and makes the errors explicit
162+-- | ```purescript
163+-- | runReader { token: "123" } someApp
164+-- | ```
165+runReader ∷ ∀ ctx err a. ctx -> AppM ctx err a -> Aff (Either (Variant err) a)
166+runReader ctx appM =
167+ runAppM_ ctx
168+ $ handleErrors (pure <<< Left)
169+ $ (Right <$> appM)
170+
171+-- | Useful when constructing a *parameterless* callback of type `Aff` or
172+-- | `Effect` within the context of an AppM computation
173+-- | ```purescript
174+-- | recordAndUploadDOM ∷ Aff _ <- do
175+-- | AppM.unliftAff $ serialiseDOM >>= uploadDOMSnapshot
176+-- | ```
177+unliftAff
178+ ∷ ∀ ctx err otherErrors a
179+ . AppM ctx err a
180+ -> AppM ctx otherErrors (Aff (Either (Variant err) a))
181+unliftAff appM = do
182+ ctx <- ask
183+ pure $ runReader ctx appM
184+
185+-- | Useful when constructing a callback of type `Aff` or `Effect` within the
186+-- | context of an AppM computation
187+-- | ```purescript
188+-- | uploadDOMDOM ∷ (SerialisedDOM -> Aff _) <- do
189+-- | AppM.unliftAffFn $ uploadDOMSnapshot
190+-- | ```
191+unliftAffFn
192+ ∷ ∀ ctx arg otherErrors a
193+ . (arg -> AppM ctx () a)
194+ -> AppM ctx otherErrors (arg -> Aff a)
195+unliftAffFn appM = do
196+ ctx <- ask
197+ pure \arg -> do
198+ runReader ctx (appM arg) <#> either case_ identity
199+
200+-- | Invoke this function in the end and handle all possible errors, e.g.
201+-- | ```purescript
202+-- | runAppM { token: "123" } { someError: \e -> handleTheError e } someApp
203+-- | ```
204+runAppM
205+ ∷ ∀ ctx r rl err_ err a
206+ . RowToList r rl
207+ => VariantMatchCases rl err_ (Aff a)
208+ => Union err_ () err
209+ => ctx
210+ -> Record r
211+ -> AppM ctx err a
212+ -> Aff a
213+runAppM ctx errorHandlers (AppM app) = do
214+ ExceptV.handleErrors errorHandlers $ runReaderT app ctx
215+
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:
220+-- | ```purescript
221+-- | do
222+-- | moreCtx <- getSomeData :: AppM {} _
223+-- | getMoreData :: AppM { moreCtx :: _ } _ # widenCtx { moreCtx }
224+-- | ```
225+widenCtx
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)) =
233+ AppM
234+ (withReaderT (disjointUnion toUnion) appM)
235+
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)
249+
250+-- liftAff = fromAff
251+-- | Helper class to make throwing errors easier
252+class VariantInjTagged a b | a -> b where
253+ injTagged ∷ Record a -> Variant b
254+
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
259+ , IsSymbol sym
260+ ) =>
261+ VariantInjTagged r1 r2 where
262+ injTagged = inj (Proxy ∷ Proxy sym) <<< get (Proxy ∷ Proxy sym)