nested routes

NestedRoutes.purs

module Main where

import HeroPrelude
import Component as C
import Counter as Counter
import Data.String as String
import Pux as Pux
import Pux.Html as H
import Pux.Router as PuxRouter
import TypeHere as TypeHere
import Control.Monad.Eff (Eff)
import Data.Array (catMaybes)
import Data.Generic (class Generic)

type RouteView a s e = Array (C.PuxComponent a s e) -> C.PuxComponent a s e
type MountPoint = String
type Path = String
data Route a s e =
      Route Path (RouteView a s e) (Array (Route a s e))
    | Mount (MountPoint × Path -> Maybe (C.PuxComponent a s e))

data RouteAction a = UrlChanged Path | ActionInRoute a
type RouteState s = {currentUrl :: Path | s}

type AppState = {currentUrl :: Path, counter :: Counter.State, typeHere :: TypeHere.State}
data AppAction = CounterAction Counter.Action | TypeHereAction TypeHere.Action
derive instance appActionGeneric :: Generic (AppAction)

init :: AppState
init = {
    currentUrl : "",
    counter : Counter.init,
    typeHere : TypeHere.init
}

helloComponent :: ∀ a s e. C.PuxComponent a s e
helloComponent = C.Stateless $ H.div [] [H.text "hello"]

otherComponent :: ∀ a s e. C.PuxComponent a s e
otherComponent = C.Stateless $ H.div [] [H.text "other component says hello too"]

route :: ∀ e. Route AppAction AppState e
route =
    Route "bla" (C.wrapManyWith navigationBar) [
        Route "blub" nestedStatefulRoute [
            Route "here" (const typeHereComp) [],
            Route "here" (const otherComponent) []
        ],
        Route "bar/foo" (const helloComponent) [],
        Route "something" (C.wrapManyWith $ caption "Here is something") [
            Mount $ map implantInApp <<< childRouter
        ]
    ]
    where

    implantInApp :: C.PuxComponent TypeHere.Action TypeHere.State e -> C.PuxComponent AppAction AppState e
    implantInApp = C.gAdaptAction TypeHereAction <<< C.adaptState _{typeHere=_} _.typeHere

    childRouter :: MountPoint × Path -> Maybe (C.PuxComponent TypeHere.Action TypeHere.State e)
    childRouter p@(mountPoint × base) = runRoute childRoute p
        where
        childRoute :: Route TypeHere.Action TypeHere.State e
        childRoute =
            Route "child" (C.wrapManyWith childNavigationBar) [
                Route "typehere" (const $ TypeHere.component) [],
                Route "a" (C.wrapManyWith $ H.span []) [
                    Route "b" (const $ C.Stateless $ H.div [] [H.text "B!"]) []
                ],
                Route "inception" (C.wrapManyWith $ caption "going deeper") [
                    Mount \mp -> childRouter mp
                ]
            ]

        childNavigationBar children =
            H.div [] $ [
                PuxRouter.link (mountPoint <> "/child/typehere") [] [H.text " typehere "],
                PuxRouter.link (mountPoint <> "/child/a/b") [] [H.text " a-b "],
                PuxRouter.link (mountPoint <> "/child/inception/child") [] [H.text " inception "]
            ] <> children

    caption :: ∀ a. String -> Array (H.Html a) -> H.Html a
    caption str children =
        H.div [] $ [
            H.h4 [] [H.text str]
        ] <> children

    navigationBar :: ∀ a. Array (H.Html a) -> H.Html a
    navigationBar children =
        H.div [] $ [
            H.div [] [
                PuxRouter.link "/bla/blub" [] [H.text " blub "],
                PuxRouter.link "/bla/something/child" [] [H.text " blub-childroute "],
                PuxRouter.link "/bla/blub/here" [] [H.text " blub-here "],
                PuxRouter.link "/bla/bar/foo" [] [H.text " bar-foo "]
            ]
        ] <> children

    nestedStatefulRoute :: RouteView AppAction AppState e
    nestedStatefulRoute childComps = C.Effectful update' view'
        where
        counterComp = Counter.component #
            C.gAdaptAction CounterAction <<< C.adaptState _{counter=_} _.counter

        update' = C.updateMany $ [counterComp] <> childComps
        view' s = H.div [] [
            H.h4 [] [H.text "something bla"],
            C.view counterComp s,
            H.div [] $ [
                H.h4 [] case childComps of
                    [] -> [H.text "Here is nothing"]
                    _ -> [H.text "Below is something"]
            ] <> (C.views s <$> childComps)
        ]

    typeHereComp :: C.PuxComponent AppAction AppState e
    typeHereComp = TypeHere.component #
        C.gAdaptAction TypeHereAction <<< C.adaptState _{typeHere=_} _.typeHere


runRoute :: ∀ a s e. Route a s e -> MountPoint × Path -> Maybe (C.PuxComponent a s e)
runRoute (Route url view' children) (mountpoint × base) = do
    --TODO parse url etc using PuxRouter.Match instead of strings...
    let currentPath = "/" <> url
    remainingPath <- String.stripPrefix currentPath base
    let newMountPoint = mountpoint <> currentPath
    let childComp = catMaybes $ flip runRoute (newMountPoint × remainingPath) <$> children
    Just $ view' childComp
runRoute (Mount mount) mb = mount mb

rootRouter :: ∀ a s e. Route a (RouteState s) e -> C.PuxComponent (RouteAction a) (RouteState s) e
rootRouter r = C.Effectful update' view'
    where
    update' (UrlChanged u) s =
        Pux.noEffects $ s{currentUrl = u}
    update' (ActionInRoute a) s =
        case runRoute r ("" × s.currentUrl) of
            Just comp -> Pux.mapEffects ActionInRoute $ C.update comp a s
            _ -> Pux.noEffects s
    view' s =
        case runRoute r ("" × s.currentUrl) of
            Just comp -> ActionInRoute <$> C.view comp s
            _ -> H.h4 [] [H.text $ s.currentUrl <> " not found!"]

main :: Eff _ Unit
main = do
    url <- PuxRouter.sampleUrl
    let rootComp = rootRouter route
    app <- Pux.start {
      initialState : init,
      update: C.update rootComp,
      view : C.view rootComp,
      inputs: [UrlChanged <$> url]
    }
    PuxRouter.navigateTo "bla/blub"
    Pux.renderToDOM "#app" app.html