Reflex (작성 예정)

-- only-reflex.hs
{-# LANGUAGE RankNTypes #-}
module Main where

import Reflex
import Reflex.Host.Class (newEventWithTriggerRef, runHostFrame, fireEvents)
import Control.Concurrent (forkIO)
import Control.Monad (forever)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Identity (Identity(..))
import Control.Monad.IO.Class (liftIO)
import Data.IORef (readIORef)
import Data.Dependent.Sum (DSum ((:=>)))
import System.IO (hSetEcho, hSetBuffering, stdin, BufferMode (NoBuffering))

type TypingApp t m = (Reflex t, MonadHold t m, MonadFix m)
                  => Event t Char
                  -> m (Behavior t String)

host :: (forall t m. TypingApp t m) -> IO ()
host myGuest =
  runSpiderHost $ do
    (e, eTriggerRef) <- newEventWithTriggerRef
    b <- runHostFrame $ myGuest e
    forever $ do
      input <- liftIO getChar
      liftIO $ putStrLn $ "Input Event: " ++ show input
      mETrigger <- liftIO $ readIORef eTriggerRef
      case mETrigger of
        Nothing -> return ()
        Just eTrigger -> fireEvents [eTrigger :=> Identity input]
      output <- runHostFrame $ sample b
      liftIO $ putStrLn $ "Output Behavior: " ++ show output

guest :: TypingApp t m
guest e = do
  d <- foldDyn (:) [] e
  return $ fmap reverse $ current d

main :: IO ()
main = do
  putStrLn "Welcome to the example Reflex host app; press Ctrl+C to exit"
  putStrLn "Press any key to process it with the Reflex FRP engine"
  hSetEcho stdin False
  hSetBuffering stdin NoBuffering
  host guest

Behavior t a

Event t a

newTriggerEvent :: TriggerEvent t m => m (Event t a, a -> IO ())

updated :: (Reflex t) => Dynamic t a -> Event t a

-- MiniReflex.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module MiniReflex where

import Control.Concurrent (threadDelay, forkIO)
import Control.Monad (forever, void)
import Data.IORef
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (when)
import Control.Monad.Fix
import System.IO.Unsafe
import Debug.Trace

-- 이벤트가 발생하면 Just a, 아니면 Nothing
newtype Event a = Event { unEvent :: IORef (Maybe a) } 

instance Functor Event where
  -- 이벤트가 들고 있는 값을 변형하는 역할을 펑터로 표현한다.
  -- 실용 코드에선 unsafePerformIO를 함부로 쓰면 안된다.
  fmap f (Event ref) = Event $ unsafePerformIO $ do
    val <- readIORef ref 
    case val of
      Just v -> do
        traceM ("Just")
        newIORef (Just (f v))
      Nothing -> do
        newIORef Nothing

-- 실제 Dynamic은 변경될 때 이벤트를 발생시킬 수 있는데, 
-- updated에서 이벤트를 만들어 내는 것으로 대체했다.
newtype Dynamic a = Dynamic { unDynamic :: IORef a }

newtype AppM a = AppM { unAppM :: IO a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

-- 이벤트를 Ref로 모델링
newEvent :: AppM (Event a, a -> IO ())
newEvent = liftIO $ do
  ref <- newIORef Nothing
  let fireFunc = \val -> writeIORef ref (Just val)
  return (Event ref, fireFunc) -- (이벤트, 트리거)

-- Dynamic을 Ref로 모델링
-- Event도 Dynamic도 Ref로 모델링하다 보니 헛갈리는데,
-- Event가 발생하면 Dynamic이 가진 Ref에 값을 넣어서
-- 이 Ref를 보고 있는 루프가 Just 값을 얻어가는 식이다.
holdDyn :: (Eq a, Show a) => a -> Event a -> AppM (Dynamic a)
holdDyn initialVal (Event evRef) = liftIO $ do
  -- 이벤트가 발생하면, 이벤트가 가진 값을 dynRef에 기억 
  dynRef <- newIORef initialVal
  void $ forkIO $ forever $ do
    eventVal <- readIORef evRef
    case eventVal of
      Just val -> do -- 이벤트가 발생했다면 Just가 들어 있다.
        oldDynVal <- readIORef dynRef
        when (val /= oldDynVal) $ writeIORef dynRef val
        writeIORef evRef Nothing -- 이벤트를 한 번 소비하면 초기화
      Nothing -> threadDelay 10000 -- 10000 밀리초마다 폴링
  return (Dynamic dynRef)

updated :: (Eq a, Show a) => Dynamic a -> AppM (Event a)
updated (Dynamic dynRef) = liftIO $ do
  evRef <- newIORef Nothing -- Dynamic이 변할 때 자동으로 fire되는 이벤트라
                            -- 따로 트리거가 없는 이벤트로 생각하면 된다.
  lastValRef <- newIORef =<< readIORef dynRef
  void $ forkIO $ do
    forever $ do
      lastVal <- readIORef lastValRef
      currentVal <- readIORef dynRef
      if currentVal /= lastVal 
        then do -- 값이 바뀌면 알리기 위해 Just 값 넣기
          writeIORef evRef (Just currentVal)
          writeIORef lastValRef currentVal
        else do
          writeIORef evRef Nothing -- 아무일도 없다는 뜻으로 Nothing
      threadDelay 10000 -- 10000 밀리초마다 폴링
  return (Event evRef)

performEvent_ :: Event Int -> AppM ()
performEvent_ (Event evRef) = liftIO $ void $ forkIO $ forever $ do
  evCount <- readIORef evRef
  let ioAction = (\n -> putStrLn $ "Current count: " ++ show n) <$> evCount
  -- Event tick 을 Event (IO a)로 변형한다.
  case ioAction of
    Just action -> do
      action
      writeIORef evRef Nothing -- 이벤트 소비
    Nothing -> do
      threadDelay 1000

runMiniReflex :: AppM () -> IO ()
runMiniReflex app = do
  unAppM app

-- Main.hs
import MiniReflex
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (forever, void)
import Control.Monad.IO.Class (liftIO)
import Data.IORef
import System.IO

main :: IO ()
main = runMiniReflex $ do
  liftIO $ hSetBuffering stdout NoBuffering
  (tickEvent, fireTick) <- newEvent
  dynCount <- holdDyn (0 :: Int) tickEvent
  evCountChanged <- updated dynCount
  performEvent_ evCountChanged

  liftIO $ putStrLn "--- Mini Reflex Counter Started ---"
  liftIO $ putStrLn "Press Enter to stop."

  void $ liftIO $ forkIO $ do
    countRef <- newIORef (0 :: Int)
    forever $ do
      threadDelay 1000000
      currentCount <- readIORef countRef
      let nextCount = currentCount + 1
      writeIORef countRef nextCount
      fireTick nextCount
  liftIO $ do
    _ <- getLine -- enter가 들어올 때까지 블록
    putStrLn "--- Mini reflex Counter Stopped ---"

data Event a = Event { subscribe :: (a -> IO ()) -> IO () } 
-- 이벤트가 발생하면 실행할 함수들을 받아 모아 둔다.

data Behavior a = Behavior (IO a)

-- 이벤트 구독에서 자주 보던, OOP에서 객체 하나 만드는 것과 비슷하다.
newEvent :: IO (Event a, a -> IO ())
newEvent = do
  subscribersRef <- newIORef []
  let event = Event $ \callback -> modifyIORef' subscribersRef (callback :) 
      trigger val = readIORef subscribersRef >>= mapM_ (\cb -> cb val)