Router

router.purs

module Router where

--http://www.parsonsmatt.org/2015/10/22/purescript_router.html
--https://github.com/parsonsmatt/purescript-routing-example/blob/master/src/Router.purs
--https://github.com/slamdata/slamdata/blob/13a6e619248386a5fd868326a1cf517c0ef124c4/src/SlamData/Prelude.purs#L116
--https://github.com/slamdata/slamdata/blob/13a6e619248386a5fd868326a1cf517c0ef124c4/src/SlamData/Workspace/Component/ChildSlot.purs


import BigPrelude
import Routing (matchesAff)
import Routing.Match (Match)
import Routing.Match.Class (lit, num)
import Component.SignUp as SignUp
import Component.Profile as Profile
import Component.Sessions as Sessions
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Control.Monad.Aff (Aff)
import Control.Monad.State.Class (modify)
import Data.Functor.Coproduct (Coproduct)
import Data.String (toLower)
import Halogen.Component.ChildPath as CP
import Data.Const (Const)

infixr 4 type Either as ⊹
infixr 4 type Coproduct as ⨁

data Input a
  = Goto Routes a

data CRUD
  = Index
  | Show Number

data Routes
  = Profile
  | Sessions CRUD
  | Home
  | SignUp

init :: State
init = { currentPage: "Home" }

routing :: Match Routes
routing = profile
      <|> signup
      <|> sessions
      <|> home
  where
    profile = Profile <$ route "profile"
    signup = SignUp <$ route "signup"
    home = Home <$ lit ""
    sessions = Sessions <$> (route "sessions" *> parseCRUD)
    route str = lit "" *> lit str
    parseCRUD = Show <$> num <|> pure Index

type State =
  { currentPage :: String
  }

type ChildQuery = Profile.Input ⨁ Sessions.Input ⨁ SignUp.Input ⨁ Const Void
type ChildSlot = Profile.Slot ⊹ Sessions.Slot ⊹ SignUp.Slot ⊹ Void

pathToProfile :: CP.ChildPath Profile.Input ChildQuery Profile.Slot ChildSlot
pathToProfile = CP.cp1

pathToSessions :: CP.ChildPath Sessions.Input ChildQuery Sessions.Slot ChildSlot
pathToSessions = CP.cp2

pathToSignUp :: CP.ChildPath SignUp.Input ChildQuery SignUp.Slot ChildSlot
pathToSignUp = CP.cp3

ui :: ∀ m. H.Component HH.HTML Input Unit Void m
ui = H.parentComponent
  { initialState: const init
  , render
  , eval
  , receiver: const Nothing
  }
  where
    render :: State -> H.ParentHTML Input ChildQuery ChildSlot m
    render st =
      HH.div_
        [ HH.h1_ [ HH.text (st.currentPage) ]
        , HH.ul_ (map link ["Sessions", "Profile", "Home", "SignUp"])
        , viewPage st.currentPage
        ]

    link s = HH.li_ [ HH.a [ HP.href ("#/" <> toLower s) ] [ HH.text s ] ]

    viewPage :: String -> H.ParentHTML Input ChildQuery ChildSlot m
    viewPage "Sessions" =
      HH.slot' pathToSessions Sessions.Slot Sessions.ui unit absurd
    viewPage "Profile" =
      HH.slot' pathToProfile Profile.Slot Profile.ui unit absurd
    viewPage "SignUp" =
      HH.slot' pathToSignUp SignUp.Slot SignUp.ui unit absurd
    viewPage _ =
      HH.div_ []

    eval :: Input ~> H.ParentDSL State Input ChildQuery ChildSlot Void m
    eval (Goto Profile next) = do
      modify (_ { currentPage = "Profile" })
      pure next
    eval (Goto SignUp next) = do
      modify (_ { currentPage = "SignUp" })
      pure next
    eval (Goto (Sessions view) next) = do
      modify case view of
                  Index -> (_ { currentPage = "Sessions" })
                  Show n -> (_ { currentPage = "Session " <> show n })
      pure next
    eval (Goto Home next) = do
      modify (_ { currentPage = "Home" })
      pure next

routeSignal :: ∀ eff. H.HalogenIO Input Void (Aff (HA.HalogenEffects eff))
            -> Aff (HA.HalogenEffects eff) Unit
routeSignal driver = do
  Tuple old new <- matchesAff routing
  redirects driver old new


-- redirects driver _ Home =
--   driver (left (action (Goto Home))))
-- redirects driver _ Profile =
--   driver (left (action (Goto Profile))))
-- redirects driver _ (Sessions view) =
--   driver (left (action (Goto (Sessions view)))))
redirects :: ∀ eff. H.HalogenIO Input Void (Aff (HA.HalogenEffects eff))
          -> Maybe Routes
          -> Routes
          -> Aff (HA.HalogenEffects eff) Unit
redirects driver _ =
  driver.query <<< H.action <<< Goto