content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE QuasiQuotes #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  
  {-
    The time-machine app transformer
   -}
  
  module Blaze.React.Examples.TimeMachine
      ( withTimeMachine
      ) where
  
  
  import           Blaze.React
  
  import           Control.Applicative
  import           Control.Lens    (makeLenses, view, (.=), (%=), use, (+=))
  import           Control.Monad
  import           Control.Monad.Trans.Writer (tell)
  
  import           Data.List       (foldl')
  import           Data.Typeable   (Typeable)
  
  import           Prelude hiding (div)
  
  import qualified Text.Blaze.Event                     as E
  import qualified Text.Blaze.Html5                     as H
  import qualified Text.Blaze.Html5.Attributes          as A
  import           Text.Show.Pretty (ppShow)
  
  
  -------------------------------------------------------------------------------
  -- Time Machine
  -------------------------------------------------------------------------------
  
  
  -- state
  --------
  
  data TMState state action = TMState
      { _tmsInternalState :: !state
      , _tmsActionHistory :: [WithWindowActions action]
        -- ^ List of actions, from earliest to latest
      , _tmsActiveAction  :: !Int
        -- ^ Index of the current position in the action list. 1-indexed,
        -- where 0 indicates that the app is in the initial state.
      , _tmsPaused        :: !Bool
      , _tmsActionBuffer  :: [WithWindowActions action]
        -- ^ This is where async internal actions go while the app is paused
      } deriving (Show)
  
  makeLenses ''TMState
  
  
  -- state transitions
  --------------------
  
  type TMAction action = WithWindowActions (TMAction' action)
  data TMAction' action
      = TogglePauseAppA
      | ClearAppHistoryA
      | RevertAppHistoryA Int
      | InternalA (WithWindowActions action)
      | AsyncInternalA (WithWindowActions action)
      deriving (Eq, Ord, Read, Show, Typeable)
  
  applyTMAction
      :: forall s a.
         s
      -> (WithWindowActions a -> Transition s (WithWindowActions a))
      -> TMAction a
      -> Transition (TMState s a) (TMAction a)
  applyTMAction initialInternalState applyInternalAction action =
      runTransitionM $ case action of
        PathChangedTo path -> do
          paused <- use tmsPaused
          unless paused $ applyInternalAction' $ PathChangedTo path
        AppAction TogglePauseAppA -> do
          paused <- use tmsPaused
          when paused flushActionBuffer
          tmsPaused %= not
        AppAction ClearAppHistoryA -> do
          tmsActionHistory .= []
          tmsInternalState .= initialInternalState
          tmsActiveAction  .= 0
        AppAction (RevertAppHistoryA idx) -> do
          history' <- take idx <$> use tmsActionHistory
          let internalState' = foldl' (\st act -> fst $ applyInternalAction act st)
                                  initialInternalState history'
          tmsInternalState .= internalState'
          tmsActiveAction .= idx
        AppAction (AsyncInternalA action') -> do
          paused <- use tmsPaused
          if paused
            then tmsActionBuffer %= (++ [action'])
            else applyInternalAction' action'
        AppAction (InternalA action') -> do
          paused <- use tmsPaused
          unless paused $ applyInternalAction' action'
    where
      flushActionBuffer :: TransitionM (TMState s a) (TMAction a)
      flushActionBuffer = do
        buffer <- use tmsActionBuffer
        sequence_ $ map applyInternalAction' buffer
        tmsActionBuffer .= []
  
      -- | Apply an internal action to the internal state, adding it to the
      -- history, bumping the active action pointer, and possibly truncating
      -- the history first.
      applyInternalAction'
          :: WithWindowActions a
          -> TransitionM (TMState s a) (TMAction a)
      applyInternalAction' act = do
        history      <- use tmsActionHistory
        activeAction <- use tmsActiveAction
        tmsActionHistory .= take activeAction history ++ [act]
  
        (internalState', reqs) <- applyInternalAction act <$> use tmsInternalState
        tmsInternalState .= internalState'
        tell $ fmap (AppAction . AsyncInternalA) <$> reqs
  
        tmsActiveAction += 1
  
  
  -- rendering
  ------------
  
  renderTMState
      :: (Show a, Show s)
      => (s -> WindowState (WithWindowActions a))
      -> TMState s a
      -> WindowState (TMAction a)
  renderTMState renderInternalState state =
      let (WindowState internalBody internalPath) =
            renderInternalState (view tmsInternalState state)
      in WindowState
        { _wsPath = internalPath
        , _wsBody = renderBody internalBody state
        }
  
  renderBody
      :: (Show a, Show s)
      => H.Html (WithWindowActions a)
      -> TMState s a
      -> H.Html (TMAction a)
  renderBody internalBody state = do
      H.div H.! A.class_ "tm-time-machine" $ do
        H.h1 "Time machine"
        H.span H.! A.class_ "tm-button" H.! E.onClick' (AppAction TogglePauseAppA) $
          if (_tmsPaused state) then "Resume app" else "Pause app"
        H.span H.! A.class_ "tm-button" H.! E.onClick' (AppAction ClearAppHistoryA) $
          "Clear history"
        renderHistoryBrowser
        renderAppStateBrowser
      H.div H.! A.class_ "tm-internal-app" $
        E.mapActions (AppAction . InternalA) $ internalBody
    where
      actionsWithIndices :: [(Int, String)]
      actionsWithIndices = reverse $
        (0, "Initial state") : (zip [1..] $ map show $ _tmsActionHistory state)
  
      renderHistoryBrowser = do
        H.h2 "Events"
        H.div H.! A.class_ "tm-history-browser" $ do
          H.ol $ forM_ actionsWithIndices $ \(idx, action) ->
            H.li H.! A.value (H.toValue $ idx + 1)
                 H.! E.onMouseEnter (\_ -> AppAction $ RevertAppHistoryA idx)
                 H.!? (idx == view tmsActiveAction state, A.class_ "tm-active-item")
                 $ H.toHtml action
  
      renderAppStateBrowser = do
        H.h2 "Application state"
        H.div H.! A.class_ "tm-app-state-browser" $ H.pre $
          H.toHtml $ ppShow $ view tmsInternalState state
  
  
  -- the application transformer
  ------------------------------
  
  withTimeMachine
      :: (Show a, Show s)
      => App s (WithWindowActions a)
      -> App (TMState s a) (TMAction a)
  withTimeMachine innerApp = App
      { appInitialState    = initialTMState initialInnerState
      , appInitialRequests = fmap (AppAction . AsyncInternalA) <$> initialInnerReqs
      , appApplyAction     = applyTMAction initialInnerState applyInnerAction
      , appRender          = renderTMState renderInner
      }
    where
      App initialInnerState initialInnerReqs applyInnerAction renderInner = innerApp
  
  initialTMState :: s -> TMState s a
  initialTMState internalState = TMState
      { _tmsInternalState = internalState
      , _tmsActionHistory = []
      , _tmsActiveAction  = 0       -- 0 indicates the initial state.
      , _tmsPaused        = False
      , _tmsActionBuffer  = []
      }
  