Patterns for building fine-grained reactive datatypes

Reactive.hs

data Triple f a b c
  = Triple1 (f a) (f b) (f c)
  | Triple2 (f a) (f b) (f c)

data TripleAction a b c where
  Triple1Fst :: (a -> a) -> TripleAction a b c
  Triple1Snd :: (b -> b) -> TripleAction a b c
  Triple1Thd :: (c -> c) -> TripleAction a b c

  Triple2Fst :: (a -> a) -> TripleAction a b c
  Triple2Snd :: (b -> b) -> TripleAction a b c
  Triple2Thd :: (c -> c) -> TripleAction a b c

  TripleReplace :: Triple Identity a b c -> TripleAction a b c

mkTriple ::
  (Reflex t, MonadHold t m, Adjustable t m, MonadFix m) =>
  Triple Identity a b c ->
  Event t (TripleAction a b c) ->
  m (Dynamic t (Triple (Dynamic t) a b c))
mkTriple z e =
  networkHold (mkNode z) $
  fmapMaybe
    (\case
        TripleReplace z' -> Just $ mkNode z'
        _ -> Nothing)
    e
  where
    mkNode n =
      case n of
        Triple1 (Identity a) (Identity b) (Identity c) ->
          Triple1 <$>
          foldDyn ($) a (fmapMaybe (\case; Triple1Fst f -> Just f; _ -> Nothing) e) <*>
          foldDyn ($) b (fmapMaybe (\case; Triple1Snd f -> Just f; _ -> Nothing) e) <*>
          foldDyn ($) c (fmapMaybe (\case; Triple1Thd f -> Just f; _ -> Nothing) e)
        Triple2 (Identity a) (Identity b) (Identity c) ->
          Triple2 <$>
          foldDyn ($) a (fmapMaybe (\case; Triple2Fst f -> Just f; _ -> Nothing) e) <*>
          foldDyn ($) b (fmapMaybe (\case; Triple2Snd f -> Just f; _ -> Nothing) e) <*>
          foldDyn ($) c (fmapMaybe (\case; Triple2Thd f -> Just f; _ -> Nothing) e)

data List f a
  = Nil
  | Cons (f a) (f (List f a))

data ListAction a where
  ListCons1 :: (a -> a) -> ListAction a
  ListCons2 :: ListAction a -> ListAction a

  ListReplace :: (List Identity a -> List Identity a) -> ListAction a

data Edit a
  = ModifyAt Int (a -> a)
  | InsertAt Int a
  | DeleteAt Int

runEdit :: Edit a -> ListAction a
runEdit (ModifyAt 0 f) = ListCons1 f
runEdit (ModifyAt n f) = ListCons2 $ runEdit (ModifyAt (n-1) f)
runEdit (DeleteAt 0) =
  ListReplace (\case; Nil -> Nil; Cons _ (Identity a) -> a)
runEdit (DeleteAt n) = ListCons2 $ runEdit (DeleteAt (n-1))
runEdit (InsertAt 0 a) = ListReplace (Cons (Identity a) . Identity)
runEdit (InsertAt n a) = ListCons2 $ runEdit (InsertAt (n-1) a)

freeze :: Monad f => List f a -> f (List Identity a)
freeze Nil = pure Nil
freeze (Cons a b) =
  (\a' b' -> Cons (Identity a') (Identity b')) <$> a <*> (freeze =<< b)

mkList ::
  (Reflex t, MonadHold t m, Adjustable t m, MonadFix m) =>
  List Identity a ->
  Event t (ListAction a) ->
  m (Dynamic t (List (Dynamic t) a))
mkList z e = do
  rec
    dList <-
      networkHold (mkNode z) $
      attachWithMaybe
        (\list -> \case
            ListReplace f ->
              Just $ mkNode . f =<< sample (current $ freeze list)
            _ -> Nothing)
        (current dList)
        e
  pure dList
  where
    mkNode n =
      case n of
        Nil -> pure Nil
        Cons (Identity a) (Identity b) ->
          Cons <$>
          foldDyn ($) a (fmapMaybe (\case; ListCons1 f -> Just f; _ -> Nothing) e) <*>
          mkList b (fmapMaybe (\case; ListCons2 f -> Just f; _ -> Nothing) e)