parentViaClass.purs

module Test.Main where

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff(), runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION(), throwException)
import Control.Monad.Free
import DOM.HTML.Types (HTMLElement())
import Data.Functor (($>))
import Data.Functor.Coproduct (Coproduct(), left, right)
import Data.Lens
import Data.Maybe (Maybe(), maybe)
import Data.String (drop)
import Data.Tuple
import Debug.Trace
import Halogen
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.Util (appendToBody)
import Prelude
import Routing
import Routing.Match
import Routing.Match.Class


type RouterState = Unit
data RouterQuery a = InitRouting a
type RouterSlot = Unit


type StateWithRouteRR q s g = InstalledState
                              RouterState s
                              RouterQuery q
                              g RouterSlot
type QueryWithRouteRR q = Coproduct RouterQuery (ChildF RouterSlot q)


class HasRouteAction q r where
  signal :: Maybe r -> r -> q Unit

instance coproductComponentHasRouteAction
         :: (HasRouteAction q r)
         => HasRouteAction (Coproduct q child) r where
  signal mb new = left $ signal mb new

routeRR
  :: forall r g q s e
   . (HasRouteAction q r)
  => Match r -> Component s q (Aff (HalogenEffects e)) -> s
  -> Component (StateWithRouteRR q s (Aff (HalogenEffects e)))
       (QueryWithRouteRR q) (Aff (HalogenEffects e))
routeRR routes comp init = parentComponent' render eval (const $ pure unit)
  where
  render _ =
    H.div [ P.initializer \_ -> action InitRouting]
    [ H.slot unit \_ -> {component: comp, initialState: init}]
  eval :: EvalParent RouterQuery RouterState s RouterQuery q (Aff (HalogenEffects e)) RouterSlot
  eval (InitRouting next) = do
    liftH $ subscribe $ eventSource matches_ \(Tuple mbOld new) -> do
      pure $ ChildF unit $ signal mbOld new
    pure next
    where
    matches_ :: (Tuple (Maybe r) r -> Eff _ Unit) -> Eff _ Unit
    matches_ hndl = matches routes (curry hndl)


runUIWithRouting
  :: forall r e q s
   . (HasRouteAction q r)
  => Match r -> Component s q (Aff (HalogenEffects e)) -> s
  -> Aff (HalogenEffects e) {driver :: Driver q e, node :: HTMLElement}
runUIWithRouting routing comp state = do
  app <- runUI (routeRR routing comp state) (installedState unit)
  pure $ {node: app.node, driver: driver_ app.driver}
  where
  driver_
    :: Natural (Coproduct _ (ChildF Unit q)) (Aff (HalogenEffects e))
    -> Natural q (Aff (HalogenEffects e))
  driver_ driver q = driver (right $ ChildF unit q)



data DummyRoutes
  = Ix Number
  | Str String
  | None

routing :: Match DummyRoutes
routing = ixMatch <|> strMatch <|> noneMatch
  where
  ixMatch = Ix <$> num
  strMatch = Str <$> str
  noneMatch = pure None

type State =
  { content :: String }

initialState :: State
initialState = { content: "ooo" }

_content :: forall a b r. Lens { content :: a | r} { content :: b | r } a b
_content = lens _.content _{content = _}

data Query a
  = Add a
  | Remove a

type Effects = HalogenEffects ()

instance parentHasRouteAction :: HasRouteAction ParentQuery DummyRoutes where
  signal mb new = ParentRouter mb new unit


comp :: Component State Query (Aff Effects)
comp = component render eval

render :: forall r. State -> ComponentHTML Query
render {content: content} =
  H.div [ ]
  [ H.button [ E.onClick (E.input_ Add) ] [ H.text "add" ]
  , H.button [ E.onClick (E.input_ Remove) ] [ H.text "remove" ]
  , H.h1_ [ H.text content ]
  ]


eval :: forall r. Natural Query (ComponentDSL State Query (Aff Effects))
eval (Add next) = modify (_content <>~ "o") $> next
eval (Remove next) = modify (_content %~ drop 1) $> next

data ParentQuery a
  = ParentRouter (Maybe DummyRoutes) DummyRoutes a
  | Clicked a
type ParentState = Int
type ParentSlot = Unit

type StateP =
  InstalledState ParentState State ParentQuery Query (Aff Effects) ParentSlot
type QueryP =
  Coproduct ParentQuery (ChildF ParentSlot Query)

parent :: Component StateP QueryP (Aff Effects)
parent = parentComponent' render eval (const $ pure unit)
  where
  render :: RenderParent ParentState State ParentQuery Query (Aff Effects) ParentSlot
  render num =
    H.div_
    [ H.slot unit \_ -> {component: comp, initialState: initialState}
    , H.button [ E.onClick (E.input_ Clicked) ] [ H.text "click me" ]
    , H.p_ [ H.text $ show num ]
    ]
  eval :: EvalParent ParentQuery
          ParentState State
          ParentQuery Query
          (Aff Effects) ParentSlot
  eval (Clicked next) = modify (\st -> st + one) $> next
  eval (ParentRouter mbOld new next) = do
    traceAnyA "PARENT"
    traceAnyA mbOld
    traceAnyA new
    pure next


main :: Eff Effects Unit
main = runAff throwException (const (pure unit)) do
  app <- runUIWithRouting routing parent (installedState 0)
  appendToBody app.node

Problems

• It's not obvious how to make parent an instance of HasRouteAction it its child is already instance.
• top level div
• I'm not sure if using this is better then just driver