Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

rhine-dom #374

Draft
wants to merge 30 commits into
base: master
Choose a base branch
from
Prev Previous commit
Next Next commit
indexAutomaton
Manuel Bärenz authored and turion committed Dec 2, 2024
commit 83f33238ce8c2fff658c36d7eb42d0a39a963e44
111 changes: 68 additions & 43 deletions rhine-tree/src/MyLib.hs
Original file line number Diff line number Diff line change
@@ -1,32 +1,39 @@
module MyLib where

-- base

import Control.Applicative (Alternative)
-- base-compat
import Data.List.Compat ((!?))
import Data.Proxy (Proxy (..))
import Data.Functor.Compat (unzip)

-- transformers
import Control.Monad.Trans.State.Strict (StateT (..))

-- text
import Data.Text hiding (index)

-- automaton

import Data.Automaton.Trans.Reader (readerS, runReaderS)
import Data.Automaton.Trans.State (runStateS)

-- rhine
import FRP.Rhine hiding (step, readerS, runReaderS)
-- lens
import Control.Lens (Index, IndexedTraversal', IxValue, Ixed (..), Lens', Prism', Traversal', failing, icompose, index, itraversed, re, reindexed, selfIndex, view, (%~), (<.), (^?))
import Control.Monad (guard)
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.State.Strict (StateT (..))
import Data.Function ((&))
import Control.Lens (Prism', IndexedTraversal', Indexable (..), itraversed, Lens', (^?), view, re, (%~), (<.), failing, selfIndex, reindexed, icompose, index, Ixed, IxValue, Index)
import Data.Functor.Compose (Compose(..))
import Data.Functor ((<&>))
import Data.Functor.Compat (unzip)
import Data.Functor.Compose (Compose (..))
-- automaton

import Types
-- rhine

-- rhine-tree

import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import Data.Stream (StreamT(..))
import Data.Monoid (Alt (..))
import Data.Proxy (Proxy (..))
import Data.Stream (StreamT (..))
import Data.Stream.Result (mapResultState, unzipResult)
import Data.Text hiding (index)
import FRP.Rhine hiding (readerS, runReaderS, step)
import Types
import Prelude hiding (unzip)

-- FIXME use MonoidAction
addPointer :: NodePointer -> DOMPointer -> DOMPointer
@@ -39,18 +46,18 @@ lookupNode :: NodePointer -> Node -> Maybe Node
lookupNode p n = n ^? iPointing . index p

data NodeEvent = NodeEvent
{ nodeEventPointer :: NodePointer
, nodeEvent :: Event
{ nodeEventPointer :: NodePointer,
nodeEvent :: NodeEvent'
}

data Event = Event
{ eventName :: Text
, payload :: Text
data NodeEvent' = NodeEvent'
{ eventName :: Text,
payload :: Text
}

data DOMEvent = DOMEvent
{ eventPointer :: DOMPointer
, domEvent :: Event
{ eventPointer :: DOMPointer,
domEvent :: NodeEvent'
}

addPointerEvent :: NodePointer -> DOMEvent -> DOMEvent
@@ -70,9 +77,9 @@ instance (MonadDOM td m, TimeDomain td, Monad m) => Clock m (DOMClock td) where
return (constM currentTime &&& constM (waitDOMEvent (Proxy @td)), initTime)

data DOMSF td m a b = DOMSF
{ focus :: DOMPointer
, domSF :: ClSF (StateT Node m) (DOMClock td) a b -- FIXME maybe I really want a SelectClock here? Or rather, the focus defines the select clock
-- It's a bit weird because I want the tag/type of the selectclock, but I'll never start it
{ focus :: DOMPointer,
domSF :: ClSF (StateT Node m) (DOMClock td) a b -- FIXME maybe I really want a SelectClock here? Or rather, the focus defines the select clock
-- It's a bit weird because I want the tag/type of the selectclock, but I'll never start it
}

-- FIXME rather a prism
@@ -92,19 +99,14 @@ subtractNodePointer (There i1 p1) (There i2 p2) = guard (i1 == i2) >> subtractNo
-- runDOMSF :: (Monad m) => DOMSF td m a b -> ClSF m (DOMClock td) (DOM, a) (DOM, Maybe b)
-- runDOMSF DOMSF {focus, domSF} = readerS $ (arr (\(ti, (dom, a)) -> (dom, (\tag -> (ti {tag}, a)) <$> filterFocus focus (tag ti))) >>>) $ runStateS $ mapMaybeS $ runReaderS domSF

-- FIXME Don't get riled up here. We really need a prism from NodePointer
moveStateDeeper :: NodePointer -> StateT Node m a -> StateT Node m a
moveStateDeeper p sma = StateT $ \s -> runStateT sma _ & _

focusState :: Functor m => Lens' s a -> StateT a m b -> StateT s m b
focusState :: (Functor m) => Lens' s a -> StateT a m b -> StateT s m b
focusState l = StateT . (getCompose .) . l . (Compose .) . runStateT

prismState :: Applicative m => Prism' s a -> StateT a m b -> StateT s m (Maybe b)
prismState :: (Applicative m) => Prism' s a -> StateT a m b -> StateT s m (Maybe b)
prismState p = StateT . (\action s -> (s ^? p & traverse action) <&> second (maybe s (view (re p))) . Data.Functor.Compat.unzip) . runStateT

-- FIXME Can generalise from [b] to Traversable t => t b?
traverseState :: IndexedTraversal' i s a -> StateT a m b -> StateT s m [b]
traverseState = _
traverseState :: (Applicative m, Alternative f) => Traversal' s a -> StateT a m b -> StateT s m (f b)
traverseState t = fmap getAlt . StateT . (getCompose .) . t . (Compose .) . runStateT . fmap (Alt . pure)

-- FIXME is this actually some kind of lens?
-- Can I generalise to not having an explicit Pointer?
@@ -124,15 +126,38 @@ iPointingDOM1 = dom . itraversed
iPointingDOM :: IndexedTraversal' DOMPointer DOM Node
iPointingDOM = icompose DOMPointer iPointingDOM1 iPointing

class HasEvent a where
type Event a :: Type
type Event a = ()

-- FIXME Maybe At is cleverer
-- FIXME use free category
data IndexList a b where
Id :: IndexList a a
Cons :: Ixed a => Index a -> IndexList (IxValue a) b -> IndexList a b
data EventList a where
EHere :: (HasEvent a) => Event a -> EventList a
EThere :: (Ixed a) => Index a -> EventList (IxValue a) -> EventList a

-- FIXME can we use FilterAutomaton
indexAutomaton1 :: (Ixed a, Monad m) => Automaton (StateT (IxValue a) m) input output -> Automaton (StateT a m) (input, Index a) [output]
indexAutomaton1 = handleAutomaton $ \StreamT {state, step} -> StreamT
{ state
, step = _
}
-- FIXME it mihgt be cleverer to put the Index in a Reader, or even supply a custom asking function
indexAutomaton1 :: (Ixed a, Monad m) => Automaton (StateT (IxValue a) m) input output -> Automaton (StateT a m) (input, Index a) (Maybe output)
indexAutomaton1 = handleAutomaton $ \StreamT {state, step} ->
StreamT
{ state,
step = \s -> ReaderT $ \(input, i) ->
let transition = step s & flip runReaderT input
maybeStep = traverseState (ix i) transition
in maybeStep <&> unzipResult <&> mapResultState (fromMaybe s)
}

-- FIXME test for nested indices
indexAutomaton ::
forall a m output input.
(Ixed a, Monad m) =>
Automaton (StateT a m) (input, Event a) output ->
Automaton (StateT (IxValue a) m) (input, EventList (IxValue a)) output ->
Automaton (StateT a m) (input, EventList a) (Maybe output)
indexAutomaton eHere eThere = arr splitEventList >>> (eHere >>> arr Just) ||| indexAutomaton1 eThere
where
-- Need this workaround because GADTs can't be matched in Arrow notation as of 9.10
splitEventList :: (input, EventList a) -> Either (input, Event a) ((input, EventList (IxValue a)), Index a)
splitEventList (input, EHere event) = Left (input, event)
splitEventList (input, EThere i eventList) = Right ((input, eventList), i)