Skip to content

Instantly share code, notes, and snippets.

@lspitzner
Last active November 15, 2017 20:20
Show Gist options
  • Save lspitzner/535ebd1aff42e3a5646b705884f64f2f to your computer and use it in GitHub Desktop.
Save lspitzner/535ebd1aff42e3a5646b705884f64f2f to your computer and use it in GitHub Desktop.
-- the basic idea, without mentioning "comonad":
data RecEvent t a = RecEvent
{ rec_current :: a
, rec_next :: R.Event t (RecEvent t a)
}
foldRecEvent :: R.Reflex t => RecEvent t a -> R.PushM t (R.Dynamic t a)
foldRecEvent r1@(RecEvent _ e1) = do
e1' <- R.headE e1
rec flattenedD <- R.holdDyn r1 $ flattenedE
let flattenedE =
R.leftmost [e1', R.switch $ R.current $ flattenedD <&> rec_next]
pure $ rec_current <$> flattenedD
-- but RecEvent is just a trivial free comonad.
-- so instead without a custom datatype:
foldCofreeEvent
:: (R.Reflex t, R.MonadHold t m, MonadFix m)
=> Cofree (R.Event t) a
-> m (R.Dynamic t a)
foldCofreeEvent cf1@(_:<e1) = do
e1' <- R.headE e1
rec flattenedD <- R.holdDyn cf1 flattenedE
let flattenedE =
R.leftmost [e1', R.switch $ R.current $ unwrap <$> flattenedD]
pure $ extract <$> flattenedD
-- Now we can use that function to write interpreters
-- for free _monads_:
-- the name is.. completely random.
-- Should probably call it .. "interpretFreeMonadInNetwork" or something?
xemira
:: forall t m f output
. (R.Reflex t, R.MonadHold t m, MonadFix m)
=> Free f output
-> (forall a . f a -> R.Event t () -> (output, R.Event t a))
-> m (R.Dynamic t output)
xemira script f = foldCofreeEvent (mkCofree R.never script)
where
mkCofree :: R.Event t () -> Free f output -> Cofree (R.Event t) output
mkCofree _initE (Pure x) = x :< R.never
mkCofree initE (Free g) =
let (d, e) = f g initE
innerE = flip R.pushAlways e $ \script' -> do
e' <- R.headE e
pure $ mkCofree (void e') script'
in d :< innerE
-- or with a monadic context in each step:
xemiraM
:: forall t m f output
. (R.Reflex t, R.MonadHold t m, MonadFix m)
=> Free f output
-> ( forall a m'
. (R.MonadHold t m', MonadFix m')
=> f a
-> R.Event t ()
-> m' (output, R.Event t a)
)
-> m (R.Dynamic t output)
xemiraM script f = foldCofreeEvent =<< mkCofree R.never script
where
mkCofree
:: (R.MonadHold t m', MonadFix m')
=> R.Event t ()
-> Free f output
-> m' (Cofree (R.Event t) output)
mkCofree _initE (Pure x) = pure $ x :< R.never
mkCofree initE (Free g) = do
(d, e) <- f g initE
let innerE = flip R.pushAlways e $ \script' -> do
e' <- R.headE e
mkCofree (void e') script'
pure $ d :< innerE
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment