Links.purs

module PushState where

import Prelude

import Control.Coroutine as CR
import Control.Coroutine.Aff as CRA
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff, class MonadEff)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (popstate)
import DOM.HTML.History (DocumentTitle(..), URL(..), pushState)
import DOM.HTML.Indexed (HTMLa)
import DOM.HTML.Location (host, pathname, protocol, search)
import DOM.HTML.Types (HISTORY, windowToEventTarget)
import DOM.HTML.Window (history, location)
import Data.Array ((:))
import Data.Either (Either(..))
import Data.Foreign (toForeign)
import Data.Functor.Coproduct (Coproduct, coproduct, right, left)
import Data.Functor.Variant (FProxy, SProxy(..), VariantF, inj, on)
import Data.Maybe (Maybe(..))
import Data.Variant (Variant)
import Halogen as H
import Halogen.Aff (HalogenEffects)
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.Query (Action, HalogenM(..))
import Routing (match)
import Routing.Match (Match)

data LinkQuery a = Goto String a
derive instance linkQueryFunctor :: Functor LinkQuery

data LinkMessage = URLChanged String

type LinkVariant v = (linkQuery :: FProxy LinkQuery | v)
type WithLinkVariant v f = (LinkVariant (userQuery :: FProxy f | v))
type WithLinkMessageVariant v m =
  (linkMessage :: LinkMessage, userMessage :: m | v)

_linkQuery :: SProxy "linkQuery"
_linkQuery = SProxy
_userQuery :: SProxy "userQuery"
_userQuery = SProxy

_linkMessage :: SProxy "linkMessage"
_linkMessage = SProxy
_userMessage :: SProxy "linkMessage"
_userMessage = SProxy

link :: forall v p. String -> HH.Node HTMLa p (VariantF (LinkVariant v) Unit)
link href props children = HH.a props' children
  where
    props' = clickProp : props
    clickProp = HE.onClick (HE.input_ (inj _linkQuery <<< Goto href))

onLinkQuery :: forall v a m e.
               Monad m =>
               MonadEff (history :: HISTORY,
                         dom :: DOM | e) m =>
               (VariantF v a -> m a) ->
               VariantF (LinkVariant v) a ->
               m a
onLinkQuery = on _linkQuery $ \(Goto url next) -> do
  history <- liftEff $ history =<< window
  liftEff $ pushState (toForeign {}) (DocumentTitle url) (URL url) history
  pure next

getRoute :: forall e. Eff (dom :: DOM | e) String
getRoute = do
  loc     <- location =<< window
  path    <- pathname loc
  search' <- search loc

  pure $ path <> search'

getRoot :: forall e. Eff (dom :: DOM | e) String
getRoot = do
  loc <- location =<< window
  p <- protocol loc
  h <- host loc

  pure $ p <> "//" <> h

pushStateProducer
  :: forall eff route.
     Match route ->
     CR.Producer route (Aff (avar :: AVAR, dom :: DOM | eff)) Unit
pushStateProducer routeMatcher = CRA.produce \emit -> do
  w <- window

  let
    target = windowToEventTarget w
    route = do
      routeStr <- getRoute
      case match routeMatcher routeStr of
        Left  _ -> pure unit -- eventually a 404?
        Right r -> emit $ Left r

  addEventListener popstate (eventListener $ pure route) false target

queryConsumer
  :: forall eff f a.
     (f ~> Aff (HalogenEffects eff)) ->
     (a -> Action f) ->
     CR.Consumer a (Aff (HallogenEffects eff)) Unit
queryConsumer query toF = CR.consumer $ \x -> do
  query $ H.action $ toF x
  pure Nothing

type WithLinkF v f = VariantF (WithLinkVariant v f)
type WithMessage v o = Variant (WithLinkMessageVariant v o)

type QueryF f = Coproduct LinkQuery f
type MessageE o = Either LinkMessage o

type LinkComponentSpec h s f i o m =
  H.ComponentSpec h s (QueryF f) i (MessageE o) m

raiseE :: forall s f g p o m. o -> HalogenM s f g p (MessageE o) m Unit
raiseE = H.raise <<< right

withLinkEval :: forall h s f o m.
                (f ~> H.ComponentDSL s f (MessageE o) m) ->
                ((QueryF f) ~> H.ComponentDSL s (QueryF f) (MessageE o) m)
withLinkEval eval = coproduct linkEval eval
  where
    linkEval (Goto url next) = do
      history <- liftEff $ history =<< window
      liftEff $ pushState (toForeign {}) (DocumentTitle url) (URL url) history
      H.raise $ Left <<< URLChanged url
      pure next

-- linkComponent :: forall h s f i o m.
--                  Bifunctor h =>
--                  ComponentSpec h s f i o m ->
--                  Component h (QueryF f) i (MessageE o) m
-- linkComponent spec =
--   H.component $ spec { render, eval }
--   where
--     render = right <<< spec.render

--     eval :: (QueryF f) ~> H.ComponentDSL s (QueryF f) (MessageE o) m
--     eval q = coproduct