Router

Route.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecursiveDo                #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

module Route where

import           Control.Lens                 (Rewrapped, Wrapped(..), iso, to, view, (^.), _Unwrapped)
import           Control.Monad.Exception      (MonadAsyncException, MonadException)
import           Control.Monad.Fix
import           Control.Monad.Reader
import           Control.Monad.Ref
import           Control.Monad.State
import           Data.ByteString              (ByteString)
import qualified Data.ByteString.Char8        as B8
import           Data.Coerce                  (coerce)
import           Data.Functor                 ((<$))
import qualified Data.List                    as List
import           Data.Text                    (Text)
import qualified Data.Text                    as T
import           Data.Text.Encoding           (decodeUtf8, encodeUtf8)
import           Foreign.JavaScript.TH
import           Language.Javascript.JSaddle  (MonadJSM)
import           Reflex
import           Reflex.Dom.Builder.Class
import           Reflex.Dom.Builder.Immediate
import           Reflex.Dom.Contrib.Router    (route')
import           Reflex.Dom.Core
import           Reflex.Host.Class
import           URI.ByteString               (URIRef, fragmentL, pathL)


data RouteContext segment t = RouteContext
  { _routeContext_allSegments    :: Dynamic t [segment]
  , _routeContext_nextSegments   :: Dynamic t [segment]
  , _routeContext_currentSegment :: Dynamic t (Maybe segment)
  }


class HasRoute segment t m | m -> segment where
  routeContext :: m (RouteContext segment t)
  withSegments :: (RouteContext segment t -> RouteContext segment t) -> m a -> m a


newtype RouteT segment t m a = RouteT { unRouteT :: ReaderT (RouteContext segment t) m a }
  deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t,
            MonadSample t, MonadAsyncException, MonadException)


instance (MonadWidget t m) => HasRoute segment t (RouteT segment t m) where
  routeContext = RouteT ask
  withSegments f (RouteT m) = RouteT $ local f m


instance Wrapped (RouteT segment t m a) where
  type Unwrapped (RouteT segment t m a) = ReaderT (RouteContext segment t) m a
  _Wrapped' = iso coerce coerce

instance RouteT segment t m a ~ x => Rewrapped (RouteT segment t m a) x

instance MonadTrans (RouteT segment t) where
  lift = RouteT . lift

instance (Reflex t, PostBuild t m) => PostBuild t (RouteT segment t m) where
  getPostBuild = view _Unwrapped getPostBuild

instance PerformEvent t m => PerformEvent t (RouteT segment t m) where
  type Performable (RouteT segment t m) = Performable m
  {-# INLINABLE performEvent_ #-}
  performEvent_ = lift . performEvent_
  {-# INLINABLE performEvent #-}
  performEvent = lift . performEvent

instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (RouteT segment t m) where
  {-# INLINABLE newEventWithTrigger #-}
  newEventWithTrigger = RouteT . lift . newEventWithTrigger
  {-# INLINABLE newFanEventWithTrigger #-}
  newFanEventWithTrigger f = RouteT $ lift $ newFanEventWithTrigger f

instance TriggerEvent t m => TriggerEvent t (RouteT segment t m) where
  {-# INLINABLE newTriggerEvent #-}
  newTriggerEvent = lift newTriggerEvent
  {-# INLINABLE newTriggerEventWithOnComplete #-}
  newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
  newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

instance MonadRef m => MonadRef (RouteT segment t m) where
  type Ref (RouteT segment t m) = Ref m
  {-# INLINABLE newRef #-}
  newRef = lift . newRef
  {-# INLINABLE readRef #-}
  readRef = lift . readRef
  {-# INLINABLE writeRef #-}
  writeRef r = lift . writeRef r

instance MonadAtomicRef m => MonadAtomicRef (RouteT segment t m) where
  {-# INLINABLE atomicModifyRef #-}
  atomicModifyRef r = lift . atomicModifyRef r

instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (RouteT segment t m) where
  runWithReplace a0 a' = RouteT $ runWithReplace (unRouteT a0) (fmapCheap unRouteT a')
  traverseDMapWithKeyWithAdjust f dm edm = RouteT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)
  traverseDMapWithKeyWithAdjustWithMove f dm edm = RouteT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)

instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT segment t m) where
  type DomBuilderSpace (RouteT segment t m) = DomBuilderSpace m
  textNode = lift . textNode
  element elementTag cfg (RouteT child) = RouteT $ element elementTag cfg child
  inputElement = lift . inputElement
  textAreaElement = lift . textAreaElement
  selectElement cfg (RouteT child) = RouteT $ selectElement cfg child
  placeRawElement = lift . placeRawElement
  wrapRawElement e = lift . wrapRawElement e

instance MonadReader r m => MonadReader r (RouteT segment t m) where
  ask = lift ask
  local f (RouteT a) = RouteT $ mapReaderT (local f) a

instance MonadState s m => MonadState s (RouteT segment t m) where
  get = lift get
  put s = lift $ put s

instance EventWriter t w m => EventWriter t w (RouteT segment t m) where
  tellEvent = lift . tellEvent


instance HasDocument m => HasDocument (RouteT segment t m)
instance HasJSContext m => HasJSContext (RouteT segment t m) where
  type JSContextPhantom (RouteT segment t m) = JSContextPhantom m
  askJSContext = RouteT askJSContext
#ifndef ghcjs_HOST_OS
instance MonadJSM m => MonadJSM (RouteT segment t m)
#endif


runRoute :: forall segment t m. (MonadWidget t m, Eq segment)
         => (forall a. URIRef a -> [segment])
         -> (forall a. URIRef a -> [segment] -> URIRef a)
         -> RouteT segment t m (Event t [segment])
         -> m ()
runRoute toSegments fromSegments (RouteT f) = do
  let
    routeHandler = route' (\_ uri -> uri) id
  rec
    dynamicRoute <- routeHandler routeChanged
    routeChanged <- pathToHandler dynamicRoute
  pure ()

  where
    pathToHandler :: Dynamic t (URIRef a) -> m (Event t (URIRef a))
    pathToHandler uri = do
      let
        allSegments = toSegments <$> uri
        ctx = RouteContext { _routeContext_allSegments    = allSegments
                           , _routeContext_nextSegments   = allSegments
                           , _routeContext_currentSegment = pure Nothing
                           }
      newSegments <- runReaderT f ctx
      let x = ffor uri $ \uri' -> fromSegments uri' <$> newSegments
      pure (switch (current x))


runRouteWithPathInFragment
  :: forall t m. (MonadWidget t m)
  => RouteT Text t m (Event t [Text])
  -> m ()
runRouteWithPathInFragment = runRoute
  (T.splitOn "/" . T.dropAround (=='/') . fragAsText)
  (\oldUrl -> setFrag oldUrl . T.intercalate "/")


withRoute :: forall segment a t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute segment t m, Eq segment)
          => (Maybe segment -> m (Event t a))
          -> m (Event t a)
withRoute f = do
  ctx <- routeContext
  let segmentsFlat = List.uncons <$> _routeContext_nextSegments ctx
  segmentsNested <- maybeDyn segmentsFlat
  let
    component = ffor segmentsNested $ \x -> case x of
      Nothing            -> do
        let newCtx = ctx{ _routeContext_currentSegment = pure Nothing
                        , _routeContext_nextSegments   = pure []
                        }
        withSegments (const newCtx) (f Nothing)

      Just segmentUncons -> do
        uniqHead <- holdUniqDyn (fst <$> segmentUncons)
        let newCtx = ctx{ _routeContext_currentSegment = Just <$> uniqHead
                        , _routeContext_nextSegments   = snd <$> segmentUncons
                        }
        ev <- dyn $ ffor uniqHead $ \segment ->
          withSegments (const newCtx) (f $ Just segment)
        switchPromptly never ev

  switchPromptly never =<< dyn component


currentRouteSegment :: (Functor m, HasRoute segment t m) => m (Dynamic t (Maybe segment))
currentRouteSegment = _routeContext_currentSegment <$> routeContext

redirectLocally :: (MonadWidget t m, HasRoute segment t m) => [segment] -> m (Event t [segment])
redirectLocally segments = (segments <$) <$> getPostBuild


setFrag :: URIRef a -> Text -> URIRef a
setFrag uri p = uri & fragmentL .~ (Just $ encodeUtf8 p)

fragAsText :: URIRef a -> Text
fragAsText uri = maybe "" decodeUtf8 (uri ^. fragmentL)

pathSegments :: URIRef a -> [ByteString]
pathSegments uri =  uri ^. pathL . to (B8.split '/')

login :: forall t m. (MonadWidget t m) => m (Event t [Text])
login =
  elAttr "div" ("id"=:"login"<>classes ["ui", "middle", "aligned", "center", "aligned", "grid"]) $
    div_ ["column"] $ do
      h2_ ["ui","blue","image","header"] $ do
        elAttr "img" ("src"=:"/img/grafted-in-g.png" <> "class"=:"image") dud

      loginUserEv <- loginForm

      signupEv <- div_ ["ui", "message"] $ do
        text "New to us? "
        a_ [] (text "Sign Up")

      pure $ leftmost [signupEv $> ["signup"], loginUserEv $> ["dashboard"]]

appRouter :: MonadWidget t m => m ()
appRouter = runRouteWithPathInFragment $ do
  _ <- login
  text "hi"
  pure never

Error:

    • Could not deduce (Reflex.Host.Class.ReflexHost t)
        arising from a use of ‘login’
      from the context: MonadWidget t m
        bound by the type signature for:
                   appRouter :: MonadWidget t m => m ()
        at /home/default/a/grafted-in/control-panel-shell/src/both/App/Front/Router.hs:10:1-36
      Possible fix:
        add (Reflex.Host.Class.ReflexHost t) to the context of
          the type signature for:
            appRouter :: MonadWidget t m => m ()
    • In a stmt of a 'do' block: login
      In the second argument of ‘($)’, namely
        ‘do { login;
              text "hi";
              pure never }’
      In the expression:
        runRouteWithPathInFragment
        $ do { login;
               text "hi";
               pure never }

Thanks to Cale, the issue is that instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (RouteT segment t m) does not actually need that ReflexHost t constraint!