|
| 1 | +module Concur.Core where |
| 2 | + |
| 3 | +import Prelude |
| 4 | + |
| 5 | +import Control.Alternative (class Alternative) |
| 6 | +import Control.Monad.Aff (Aff, never, runAff_) |
| 7 | +import Control.Monad.Aff.AVar (AVar, takeVar) |
| 8 | +import Control.Monad.Aff.Class (class MonadAff, liftAff) |
| 9 | +import Control.Monad.Aff.Unsafe (unsafeCoerceAff) |
| 10 | +import Control.Monad.Eff (Eff) |
| 11 | +import Control.Monad.Eff.AVar (makeEmptyVar, tryPutVar) |
| 12 | +import Control.Monad.Eff.Class (class MonadEff, liftEff) |
| 13 | +import Control.Monad.Eff.Console (log) |
| 14 | +import Control.Monad.Free (Free, hoistFree, resume, liftF, wrap) |
| 15 | +import Control.Monad.IO (IO) |
| 16 | +import Control.Monad.IOSync (IOSync) |
| 17 | +import Control.Parallel.Class (parallel, sequential) |
| 18 | +import Control.Plus (class Alt, class Plus, alt, (<|>), empty) |
| 19 | +import Data.Either (Either(..)) |
| 20 | +import Data.Foldable (foldl) |
| 21 | +import Data.Monoid (class Monoid, mempty) |
| 22 | + |
| 23 | +newtype WidgetStep v a = WidgetStep (IOSync |
| 24 | + { view :: v |
| 25 | + , cont :: IO a |
| 26 | + }) |
| 27 | + |
| 28 | +unWidgetStep :: forall v a. WidgetStep v a -> IOSync { view :: v, cont :: IO a } |
| 29 | +unWidgetStep (WidgetStep x) = x |
| 30 | + |
| 31 | +instance functorWidgetStep :: Functor (WidgetStep v) where |
| 32 | + map f (WidgetStep w) = WidgetStep (map mod w) |
| 33 | + where mod ws = ws { cont = map f ws.cont } |
| 34 | + |
| 35 | +displayStep :: forall a v. v -> WidgetStep v a |
| 36 | +displayStep v = WidgetStep (pure { view: v, cont: liftAff never }) |
| 37 | + |
| 38 | +newtype Widget v a = Widget (Free (WidgetStep v) a) |
| 39 | + |
| 40 | +unWidget :: forall v a. Widget v a -> Free (WidgetStep v) a |
| 41 | +unWidget (Widget w) = w |
| 42 | + |
| 43 | +instance widgetFunctor :: Functor (Widget v) where |
| 44 | + map k (Widget w) = Widget (map k w) |
| 45 | + |
| 46 | +instance widgetBind :: Bind (Widget v) where |
| 47 | + bind (Widget w) f = Widget (bind w (unWidget <<< f)) |
| 48 | + |
| 49 | +instance widgetApplicative :: Applicative (Widget v) where |
| 50 | + pure = Widget <<< pure |
| 51 | + |
| 52 | +instance widgetApply :: Apply (Widget v) where |
| 53 | + apply = ap |
| 54 | + |
| 55 | +instance widgetMonad :: Monad (Widget v) |
| 56 | + |
| 57 | +instance widgetSemigroup :: Semigroup v => Semigroup (Widget v a) where |
| 58 | + append (Widget w1) (Widget w2) = Widget (appendFree w1 w2) |
| 59 | + where |
| 60 | + appendFree w1' w2' = |
| 61 | + case resume w1' of |
| 62 | + Right a1 -> pure a1 |
| 63 | + Left ws1 -> case resume w2' of |
| 64 | + Right a2 -> pure a2 |
| 65 | + Left ws2 -> wrap (appendWidgetStep ws1 ws2) |
| 66 | + appendWidgetStep (WidgetStep wsm1) (WidgetStep wsm2) = WidgetStep $ do |
| 67 | + ws1 <- wsm1 |
| 68 | + ws2 <- wsm2 |
| 69 | + let v = ws1.view <> ws2.view |
| 70 | + let c = do |
| 71 | + e <- sequential (alt (parallel (map Left ws1.cont)) (parallel (map Right ws2.cont))) |
| 72 | + pure $ case e of |
| 73 | + -- Taking care to not run any of the effects again |
| 74 | + Left e' -> appendFree e' (wrap (WidgetStep (pure ws2))) |
| 75 | + Right e' -> appendFree (wrap (WidgetStep (pure ws1))) e' |
| 76 | + pure { view: v, cont: c } |
| 77 | + |
| 78 | +instance widgetAlt :: Semigroup v => Alt (Widget v) where |
| 79 | + alt = append |
| 80 | + |
| 81 | +instance widgetPlus :: Monoid v => Plus (Widget v) where |
| 82 | + empty = display mempty |
| 83 | + |
| 84 | +instance widgetAlternative :: Monoid v => Alternative (Widget v) |
| 85 | + |
| 86 | +mapView :: forall a v. (v -> v) -> Widget v a -> Widget v a |
| 87 | +mapView f (Widget w) = Widget (hoistFree (mapViewStep f) w) |
| 88 | + |
| 89 | +mapViewStep :: forall v1 v2 a. (v1 -> v2) -> WidgetStep v1 a -> WidgetStep v2 a |
| 90 | +mapViewStep f (WidgetStep ws) = WidgetStep (map mod ws) |
| 91 | + where mod ws' = ws' { view = f ws'.view } |
| 92 | + |
| 93 | +display :: forall a v. v -> Widget v a |
| 94 | +display v = Widget (liftF (displayStep v)) |
| 95 | + |
| 96 | +orr :: forall m a. Plus m => Array (m a) -> m a |
| 97 | +orr = foldl (<|>) empty |
| 98 | + |
| 99 | +-- Sync but Non blocking eff |
| 100 | +effAction :: forall a v eff. v -> Eff eff a -> Widget v a |
| 101 | +effAction v eff = affAction v $ liftEff eff |
| 102 | + |
| 103 | +-- Sync and blocking eff |
| 104 | +-- WARNING: UNSAFE: This will block the UI rendering |
| 105 | +unsafeBlockingEffAction :: forall a v eff. v -> Eff eff a -> Widget v a |
| 106 | +unsafeBlockingEffAction v eff = Widget $ liftF $ WidgetStep $ |
| 107 | + liftEff eff >>= \a -> pure { view: v, cont: pure a } |
| 108 | + |
| 109 | +-- Async aff |
| 110 | +affAction :: forall a v eff. v -> Aff eff a -> Widget v a |
| 111 | +affAction v aff = Widget $ liftF $ WidgetStep $ do |
| 112 | + var <- liftEff $ do |
| 113 | + var <- makeEmptyVar |
| 114 | + runAff_ (handler var) (unsafeCoerceAff aff) |
| 115 | + pure var |
| 116 | + pure { view: v, cont: liftAff (takeVar var) } |
| 117 | + where |
| 118 | + handler _ (Left e) = log ("Aff failed - " <> show e) |
| 119 | + handler var (Right a) = void (tryPutVar a var) |
| 120 | + |
| 121 | +instance widgetMonadEff :: Monoid v => MonadEff eff (Widget v) where |
| 122 | + liftEff = effAction mempty |
| 123 | + |
| 124 | +instance widgetMonadAff :: Monoid v => MonadAff eff (Widget v) where |
| 125 | + liftAff = affAction mempty |
| 126 | + |
| 127 | +-- Helpers for some very common use of unsafe blocking io |
| 128 | + |
| 129 | +-- Construct a widget from a primitive view event |
| 130 | +withViewEvent :: forall a v. ((a -> IOSync Unit) -> v) -> Widget v a |
| 131 | +withViewEvent mkView = Widget (liftF (WidgetStep (do |
| 132 | + v <- liftEff makeEmptyVar |
| 133 | + pure { view: mkView (\a -> void (liftEff (tryPutVar a v))), cont: liftAff (takeVar v) } |
| 134 | + ))) |
| 135 | + |
| 136 | +-- Construct a widget, by wrapping an existing widget in a view event |
| 137 | +-- Returns Left on view event firing, Right on wrapped widget finishing |
| 138 | +wrapViewEvent :: forall a b v. (AVar (Free (WidgetStep v) (Either a b)) -> v -> v) -> Widget v b -> Widget v (Either a b) |
| 139 | +wrapViewEvent mkView (Widget w) = Widget $ |
| 140 | + case resume w of |
| 141 | + Right a -> pure (Right a) |
| 142 | + Left (WidgetStep wsm) -> wrap $ WidgetStep $ do |
| 143 | + ws <- wsm |
| 144 | + var <- liftEff makeEmptyVar |
| 145 | + let view' = mkView var ws.view |
| 146 | + let cont' = sequential (alt (parallel (liftAff (takeVar var))) (parallel (map (map Right) ws.cont))) |
| 147 | + pure {view: view', cont: cont'} |
0 commit comments