VDom.purs

module Concur.VDom where

import Prelude

import Control.Alt (alt)
import Control.Alternative (class Alternative, (<|>))
import Control.Monad.Aff (forkAff, launchAff_)
import Control.Monad.Aff.AVar (makeEmptyVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.AVar (AVar)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.IO (IO, INFINITY, runIO')
import Control.Monad.IO.Class (class MonadIO, liftIO)
import Control.Monad.Rec.Class (class MonadRec, Step(Done, Loop), tailRecM)
import Control.Parallel.Class (parallel, sequential)
import Control.Plus (class Alt, class Plus, empty)
import DOM (DOM)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument, htmlDocumentToParentNode) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.Node (appendChild) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import DOM.Node.Types (elementToNode) as DOM
import Data.Array (foldl)
import Data.Either (Either(..), either)
import Data.Foldable (for_)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (wrap)
import Halogen.VDom as V
import Halogen.VDom.DOM.Prop (Prop(..), buildProp, propFromString) as P
import Halogen.VDom.Machine (never) as Machine

type Prop = P.Prop (IO Unit)

infixr 1 prop as :=

prop :: forall a. String -> String -> P.Prop a
prop key val = P.Property key (P.propFromString val)

type VDom = V.VDom (Array Prop) Void

-- | A widget may
-- | * return a value immediately
-- | * do arbitrary IO, blocking until yielding a value
-- | * render a view without ever returning (static markup)
-- | * render a view and later continue with a new widget (like DOM events)
data Widget a
  = WidgetIO (IO { view :: Array VDom, cont :: Maybe (AVar (Widget a)) })
  | RenderEnd a

instance widgetFunctor :: Functor Widget where
  map f (RenderEnd a) = RenderEnd (f a)
  map f (WidgetIO io) = WidgetIO do
    { view, cont: next } <- io
    case next of
      Nothing -> pure { view, cont: Nothing }
      Just var -> do
        cont' <- liftAff makeEmptyVar
        _ <- liftAff $ forkAff do
          w <- takeVar var
          putVar (f <$> w) cont'
        pure { view, cont: Just cont' }

instance renderBind :: Bind Widget where
  bind (RenderEnd a) k = k a
  bind (WidgetIO io) k = WidgetIO do
    { view, cont } <- io
    case cont of
      Nothing -> pure { view, cont: Nothing }
      Just var -> do
        cont' <- liftAff makeEmptyVar
        _ <- liftAff $ forkAff $ do
          w <- takeVar var
          putVar (w >>= k) cont'
        pure { view, cont: Just cont' }

instance renderApplicative :: Applicative Widget where
  pure = RenderEnd

instance renderApply :: Apply Widget where
  apply = ap

instance renderMonad :: Monad Widget

instance liftIOWidget :: MonadIO Widget where
  liftIO io = WidgetIO do
    v <- io
    var <- liftAff $ makeVar $ pure v
    pure { view: mempty, cont: Just var }

instance liftEffWidget :: MonadEff eff Widget where
  liftEff = liftIO <<< liftEff

instance monadAffWidget :: MonadAff eff Widget where
  liftAff = liftIO <<< liftAff

instance monadRecWidget :: MonadRec Widget where
  tailRecM f a = go =<< f a
    where
      go (Loop a') = tailRecM f a'
      go (Done b) = pure b

instance renderAlt :: Alt Widget where
  alt (RenderEnd a) _ = RenderEnd a
  alt _ (RenderEnd a) = RenderEnd a
  alt (WidgetIO a) (WidgetIO b) = WidgetIO do
    a' <- a
    b' <- b
    case a'.cont, b'.cont of
      Nothing, Nothing -> pure { view: a'.view <> b'.view, cont: Nothing }
      Just var, Nothing ->  pure { view: a'.view <> b'.view, cont: Just var }
      Nothing, Just var -> pure { view: a'.view <> b'.view, cont: Just var }
      Just v1, Just v2 -> do
        var <- liftAff makeEmptyVar
        _ <- liftAff $ forkAff do
          next <- sequential $ (Left <$> parallel (takeVar v1)) <|> (Right <$> parallel (takeVar v2))
          let next' = either (flip alt (WidgetIO (pure b')))
                             (alt (WidgetIO (pure a')))
                             next
          putVar next' var
        pure { view: a'.view <> b'.view, cont: Just var }

instance renderPlus :: Plus Widget where
  empty = display mempty

instance renderAlternative :: Alternative Widget

mapView :: forall a. (Array VDom -> Array VDom) -> Widget a -> Widget a
mapView f (WidgetIO io) = WidgetIO do
  { view, cont } <- io
  pure { view: f view, cont }
mapView _ r = r

orr :: forall a. Array (Widget a) -> Widget a
orr = foldl (<|>) empty

el :: forall a. String -> Array Prop -> Widget a -> Widget a
el name props = mapView (\c -> [V.Elem (V.ElemSpec Nothing (V.ElemName name) props) c])

el' :: forall a. String -> Array Prop -> Array (Widget a) -> Widget a
el' n props = el n props <<< orr

display :: forall a. Array VDom -> Widget a
display v = WidgetIO $ pure { view: v, cont: Nothing }

text :: forall a. String -> Widget a
text t = display [V.Text t]

runWidget :: forall eff. Widget Unit -> Eff (ref ∷ REF, dom ∷ DOM, infinity :: INFINITY | eff) Unit
runWidget widget = do
  win <- DOM.window
  doc <- DOM.document win
  bod <- DOM.querySelector (wrap "body") (DOM.htmlDocumentToParentNode doc)
  for_ bod \body -> do
    let spec = V.VDomSpec
          { buildWidget: const (Machine.never)
          , buildAttributes: P.buildProp (launchAff_ <<< runIO')
          , document: DOM.htmlDocumentToDocument doc
          }

    ref <- Ref.newRef Nothing

    let
      step :: Widget Unit -> IO Unit
      step w = do
        machine <- liftEff $ Ref.readRef ref
        children <- render w
        let wrapper = V.Elem (V.ElemSpec Nothing (V.ElemName "div") []) children
        maybe (initialize wrapper) (next wrapper) machine

      initialize :: VDom -> IO Unit
      initialize vdom = liftEff do
        initMachine <- V.buildVDom spec vdom
        _ ← DOM.appendChild (V.extract initMachine) (DOM.elementToNode body)
        Ref.writeRef ref (Just initMachine)

      next vdom machine = liftEff do
        res ← V.step machine vdom
        Ref.writeRef ref (Just res)

      render :: Widget Unit -> IO (Array VDom)
      render = case _ of
        (RenderEnd a) -> pure []
        (WidgetIO io) -> do
          { view, cont } <- io
          case cont of
            Nothing -> pure view
            Just var -> do
              _ <- liftAff $ forkAff do
                next' <- takeVar var
                runIO' $ step next'
              pure view

    launchAff_ $ runIO' (step widget)