├── CHANGELOG.md ├── LICENSE ├── README.md ├── Reflex └── Dom │ └── Routing │ ├── Nested.hs │ └── Writer.hs └── reflex-dom-nested-routing.cabal /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | 3 | ## 0.0.3 4 | 5 | * **[Breaking change]** Reorganize modules. 6 | 7 | ## 0.0.2 8 | 9 | * **[Breaking change]** Fix `parentRouteSegments` which was giving "grandparent" route instead of parent. 10 | 11 | ## 0.0.1 12 | 13 | * Initial prototype. 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Elliot Cameron 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Elliot Cameron nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Nested Routing for Reflex-DOM 2 | 3 | [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)](http://www.haskell.org) 4 | [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)](https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29) 5 | 6 | Example: 7 | 8 | ```haskell 9 | app = runRouteWithPathInFragment $ do 10 | switchPromptly never <=< withRoute $ \route -> case fromMaybe "" route of 11 | "" -> (["users"] <$) <$> buttonClick "Open users" 12 | "users" -> users 13 | "test" -> codeToRun >> pure never 14 | "settings" -> text "Settings" >> pure never 15 | _ -> redirectLocally [] 16 | ``` 17 | 18 | `RouteWriter` can make plumbing easer: 19 | 20 | 21 | ```haskell 22 | app = runRouteWithPathInFragment $ fmap snd $ runRouteWriterT $ do 23 | void $ withRoute $ \route -> case fromMaybe "" route of 24 | "" -> tellRouteAs ["users"] =<< buttonClick "Open users" 25 | "users" -> users 26 | "test" -> codeToRun 27 | "settings" -> text "Settings" 28 | _ -> tellRedirectLocally [] 29 | ``` 30 | 31 | -------------------------------------------------------------------------------- /Reflex/Dom/Routing/Nested.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecursiveDo #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module Reflex.Dom.Routing.Nested where 15 | 16 | import Control.Lens (Rewrapped, Wrapped (..), iso, to, 17 | (^.)) 18 | import Control.Monad.Exception (MonadAsyncException, 19 | MonadException) 20 | import Control.Monad.Fix 21 | import Control.Monad.Primitive (PrimMonad, PrimState, primitive) 22 | import Control.Monad.Reader 23 | import Control.Monad.Ref 24 | import Control.Monad.State 25 | import qualified Control.Monad.State.Strict as StrictState 26 | import Data.ByteString (ByteString) 27 | import qualified Data.ByteString.Char8 as B8 28 | import Data.Coerce (coerce) 29 | import Data.Functor ((<$)) 30 | import qualified Data.List as List 31 | import Data.Maybe (listToMaybe) 32 | import Data.Text (Text) 33 | import qualified Data.Text as T 34 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 35 | import Language.Javascript.JSaddle (MonadJSM) 36 | import Reflex 37 | import Reflex.Dom.Builder.Class 38 | import Reflex.Dom.Builder.Immediate 39 | import Reflex.Dom.Contrib.Router (route') 40 | import Reflex.Dom.Core 41 | import Reflex.Host.Class 42 | import URI.ByteString (URIRef, fragmentL, pathL) 43 | 44 | 45 | data RouteContext segment t = RouteContext 46 | { _routeContext_allSegments :: !(Dynamic t [segment]) 47 | , _routeContext_nextSegments :: !(Dynamic t [segment]) 48 | , _routeContext_currentSegment :: !(Dynamic t (Maybe segment)) 49 | , _routeContext_currentDepth :: !Int 50 | } 51 | 52 | 53 | class (Reflex t, Monad m) => HasRoute t segment m | m -> segment, m -> t where 54 | routeContext :: m (RouteContext segment t) 55 | withSegments :: (RouteContext segment t -> RouteContext segment t) -> m a -> m a 56 | 57 | 58 | newtype RouteT t segment m a = RouteT { unRouteT :: ReaderT (RouteContext segment t) m a } 59 | deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, 60 | MonadSample t, MonadAsyncException, MonadException, MonadTrans, PostBuild t, 61 | MonadReflexCreateTrigger t, TriggerEvent t, MonadAtomicRef) 62 | 63 | 64 | instance (MonadWidget t m) => HasRoute t segment (RouteT t segment m) where 65 | routeContext = RouteT ask 66 | withSegments f (RouteT m) = RouteT $ local f m 67 | 68 | instance Requester t m => Requester t (RouteT t segment m) where 69 | type Request (RouteT t segment m) = Request m 70 | type Response (RouteT t segment m) = Response m 71 | requesting = lift . requesting 72 | requesting_ = lift . requesting_ 73 | 74 | instance HasRoute t segment m => HasRoute t segment (RequesterT t request response m) where 75 | routeContext = lift routeContext 76 | withSegments f (RequesterT a) = RequesterT $ StrictState.mapStateT (mapReaderT $ withSegments f) a 77 | 78 | instance Wrapped (RouteT t segment m a) where 79 | type Unwrapped (RouteT t segment m a) = ReaderT (RouteContext segment t) m a 80 | _Wrapped' = iso coerce coerce 81 | 82 | instance RouteT t segment m a ~ x => Rewrapped (RouteT t segment m a) x 83 | 84 | instance PerformEvent t m => PerformEvent t (RouteT t segment m) where 85 | type Performable (RouteT t segment m) = Performable m 86 | {-# INLINABLE performEvent_ #-} 87 | performEvent_ = lift . performEvent_ 88 | {-# INLINABLE performEvent #-} 89 | performEvent = lift . performEvent 90 | 91 | instance MonadRef m => MonadRef (RouteT t segment m) where 92 | type Ref (RouteT t segment m) = Ref m 93 | {-# INLINABLE newRef #-} 94 | newRef = lift . newRef 95 | {-# INLINABLE readRef #-} 96 | readRef = lift . readRef 97 | {-# INLINABLE writeRef #-} 98 | writeRef r = lift . writeRef r 99 | 100 | instance (Adjustable t m, MonadHold t m) => Adjustable t (RouteT t segment m) where 101 | runWithReplace a0 a' = RouteT $ runWithReplace (unRouteT a0) (fmapCheap unRouteT a') 102 | traverseDMapWithKeyWithAdjust f dm edm = RouteT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm) 103 | {-# INLINABLE traverseDMapWithKeyWithAdjust #-} 104 | traverseDMapWithKeyWithAdjustWithMove f dm edm = RouteT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm) 105 | 106 | instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT t segment m) where 107 | type DomBuilderSpace (RouteT t segment m) = DomBuilderSpace m 108 | textNode = lift . textNode 109 | element elementTag cfg (RouteT child) = RouteT $ element elementTag cfg child 110 | inputElement = lift . inputElement 111 | textAreaElement = lift . textAreaElement 112 | selectElement cfg (RouteT child) = RouteT $ selectElement cfg child 113 | placeRawElement = lift . placeRawElement 114 | wrapRawElement e = lift . wrapRawElement e 115 | 116 | instance (Monad m, NotReady t m) => NotReady t (RouteT t segment m) 117 | 118 | instance MonadReader r m => MonadReader r (RouteT t segment m) where 119 | ask = lift ask 120 | local f (RouteT a) = RouteT $ mapReaderT (local f) a 121 | 122 | deriving instance MonadState s m => MonadState s (RouteT t segment m) 123 | 124 | instance HasRoute t segment m => HasRoute t segment (EventWriterT t w m) where 125 | routeContext = lift routeContext 126 | withSegments f (EventWriterT a) = EventWriterT $ StrictState.mapStateT (withSegments f) a 127 | 128 | instance EventWriter t w m => EventWriter t w (RouteT t segment m) where 129 | tellEvent = lift . tellEvent 130 | 131 | instance HasRoute t segment m => HasRoute t segment (DynamicWriterT t w m) where 132 | routeContext = lift routeContext 133 | withSegments f (DynamicWriterT a) = DynamicWriterT $ StrictState.mapStateT (withSegments f) a 134 | 135 | instance DynamicWriter t w m => DynamicWriter t w (RouteT t segment m) where 136 | tellDyn = lift . tellDyn 137 | 138 | instance HasDocument m => HasDocument (RouteT t segment m) 139 | 140 | #ifndef ghcjs_HOST_OS 141 | instance MonadJSM m => MonadJSM (RouteT t segment m) 142 | #endif 143 | 144 | deriving instance DomRenderHook t m => DomRenderHook t (RouteT t segment m) 145 | 146 | instance (Prerender t m, Monad m, Reflex t) => Prerender t (RouteT t segment m) where 147 | type Client (RouteT t segment m) = RouteT t segment (Client m) 148 | prerender (RouteT a) (RouteT b) = RouteT $ prerender a b 149 | 150 | 151 | instance PrimMonad m => PrimMonad (RouteT t segment m) where 152 | type PrimState (RouteT t segment m) = PrimState m 153 | primitive = lift . primitive 154 | 155 | --instance HasMountStatus t m => HasMountStatus t (RouteT segment r m) where 156 | -- getMountStatus = lift getMountStatus 157 | 158 | -- | Runs a monadic action (in 'RouteT') over the current URL as "interpreted" 159 | -- by the given URL-parser. The action must return an 'Event' which can trigger 160 | -- the route to change. 161 | runRoute :: forall segment t m. (MonadWidget t m, Eq segment) 162 | => (forall a. URIRef a -> [segment]) 163 | -> (forall a. URIRef a -> [segment] -> URIRef a) 164 | -> RouteT t segment m (Event t [segment]) 165 | -> m () 166 | runRoute toSegments fromSegments (RouteT f) = do 167 | let 168 | routeHandler = route' (\_ uri -> uri) id 169 | rec 170 | dynamicRoute <- routeHandler routeChanged 171 | routeChanged <- pathToHandler dynamicRoute 172 | pure () 173 | 174 | where 175 | pathToHandler :: Dynamic t (URIRef a) -> m (Event t (URIRef a)) 176 | pathToHandler uri = do 177 | let 178 | allSegments = toSegments <$> uri 179 | ctx = RouteContext{ _routeContext_allSegments = allSegments 180 | , _routeContext_nextSegments = allSegments 181 | , _routeContext_currentSegment = pure Nothing 182 | , _routeContext_currentDepth = 0 183 | } 184 | newSegments <- runReaderT f ctx 185 | let x = ffor uri $ \uri' -> fromSegments uri' <$> newSegments 186 | pure (switch (current x)) 187 | 188 | -- | A very simple version of 'runRoute' that parses only the URL fragment 189 | -- and splits it over @/@. Each path segment is therefore nothing more than 'Text'. 190 | runRouteWithPathInFragment 191 | :: forall t m. (MonadWidget t m) 192 | => RouteT t Text m (Event t [Text]) 193 | -> m () 194 | runRouteWithPathInFragment = runRoute 195 | (nullTextToEmptyList . T.splitOn "/" . T.dropAround (=='/') . fragAsText) 196 | (\oldUrl -> setFrag oldUrl . T.intercalate "/") 197 | where 198 | nullTextToEmptyList [""] = [] 199 | nullTextToEmptyList x = x 200 | 201 | -- | Introduces a new "layer" in the nested routing tree. The given function takes 202 | -- the current layer's route segment and builds the DOM for that segment. 203 | withRoute 204 | :: forall a segment t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute t segment m, Eq segment) 205 | => (Maybe segment -> m a) 206 | -- ^ A routing function that produces a widget from a segment. 207 | -> m (Event t a) 208 | withRoute f = do 209 | ctx <- routeContext 210 | let segmentsFlat = List.uncons <$> _routeContext_nextSegments ctx 211 | segmentsNested <- maybeDyn segmentsFlat 212 | 213 | let 214 | nextDepth = 1 + _routeContext_currentDepth ctx 215 | 216 | component = ffor segmentsNested $ \x -> case x of 217 | Nothing -> do 218 | let 219 | segment = Nothing 220 | newCtx = ctx{ _routeContext_currentSegment = pure segment 221 | , _routeContext_nextSegments = pure [] 222 | , _routeContext_currentDepth = nextDepth 223 | } 224 | 225 | a <- withSegments (const newCtx) (f segment) 226 | postBuildEv <- getPostBuild 227 | pure (a <$ postBuildEv) -- Wrap the value up in an Event to unify both paths. 228 | 229 | Just segmentUncons -> do 230 | segmentDyn <- fmap Just <$> holdUniqDyn (fst <$> segmentUncons) 231 | let newCtx = ctx{ _routeContext_currentSegment = segmentDyn 232 | , _routeContext_nextSegments = snd <$> segmentUncons 233 | , _routeContext_currentDepth = nextDepth 234 | } 235 | 236 | dyn $ ffor segmentDyn $ \segment -> 237 | withSegments (const newCtx) (f segment) 238 | 239 | switchPromptly never =<< dyn component 240 | 241 | -- | All routing segments in the current URL. 242 | allRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment]) 243 | allRouteSegments = _routeContext_allSegments <$> routeContext 244 | 245 | -- | The routing segment at "this layer" in the tree. "This layer" is defined by how many 246 | -- nested 'withRoute's exist above the caller of this function. 247 | currentRouteSegment :: (Functor m, HasRoute t segment m) => m (Dynamic t (Maybe segment)) 248 | currentRouteSegment = _routeContext_currentSegment <$> routeContext 249 | 250 | -- | The next layer's segment in the tree. Like 'withRoute' this can be used to switch 251 | -- over route segments, but it does not place a new layer in the tree. 252 | nextRouteSegment :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t (Maybe segment)) 253 | nextRouteSegment = do 254 | ctx <- routeContext 255 | holdUniqDyn (listToMaybe <$> _routeContext_nextSegments ctx) 256 | 257 | -- | Route segments from parent layers. 258 | parentRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment]) 259 | parentRouteSegments = do 260 | ctx <- routeContext 261 | holdUniqDyn $ take (_routeContext_currentDepth ctx) <$> _routeContext_allSegments ctx 262 | 263 | -- | Route segments from child layers. 264 | childRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment]) 265 | childRouteSegments = holdUniqDyn =<< _routeContext_nextSegments <$> routeContext 266 | 267 | -- | A simple helper that produces a routing event on 'getPostBuild'. 268 | redirectLocally :: (PostBuild t m) => [segment] -> m (Event t [segment]) 269 | redirectLocally segments = (segments <$) <$> getPostBuild 270 | 271 | 272 | setFrag :: URIRef a -> Text -> URIRef a 273 | setFrag uri p = uri & fragmentL .~ (Just $ encodeUtf8 p) 274 | 275 | fragAsText :: URIRef a -> Text 276 | fragAsText uri = maybe "" decodeUtf8 (uri ^. fragmentL) 277 | 278 | pathSegments :: URIRef a -> [ByteString] 279 | pathSegments uri = uri ^. pathL . to (B8.split '/') 280 | -------------------------------------------------------------------------------- /Reflex/Dom/Routing/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Reflex.Dom.Routing.Writer where 13 | 14 | import Control.Lens (Rewrapped, Wrapped (..), iso) 15 | import Control.Monad.Exception (MonadAsyncException, 16 | MonadException) 17 | import Control.Monad.Fix 18 | import Control.Monad.Primitive (PrimMonad, PrimState, primitive) 19 | import Control.Monad.Reader 20 | import Control.Monad.Ref 21 | import qualified Control.Monad.State.Strict as StrictState 22 | import Data.Coerce (coerce) 23 | import Language.Javascript.JSaddle (MonadJSM) 24 | import Reflex 25 | import Reflex.Dom.Builder.Class 26 | import Reflex.Dom.Builder.Immediate 27 | import Reflex.Dom.Core 28 | import Reflex.Host.Class 29 | 30 | import Reflex.Dom.Routing.Nested 31 | 32 | 33 | class (Reflex t, Monad m) => RouteWriter t segment m | m -> segment, m -> t where 34 | tellRoute :: Event t [segment] -> m () 35 | 36 | newtype RouteWriterT t segment m a = RouteWriterT { unRouteWriterT :: EventWriterT t [segment] m a } 37 | deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, 38 | MonadSample t, MonadAsyncException, MonadException, MonadTrans, PostBuild t, 39 | MonadReflexCreateTrigger t, TriggerEvent t, MonadAtomicRef) 40 | 41 | 42 | instance (MonadWidget t m) => RouteWriter t segment (RouteWriterT t segment m) where 43 | tellRoute = RouteWriterT . tellEvent 44 | 45 | deriving instance DomRenderHook t m => DomRenderHook t (RouteWriterT t segment m) 46 | 47 | instance (Prerender t m, Monad m, Reflex t) => Prerender t (RouteWriterT t segment m) where 48 | type Client (RouteWriterT t segment m) = RouteWriterT t segment (Client m) 49 | prerender (RouteWriterT a) (RouteWriterT b) = RouteWriterT $ prerender a b 50 | 51 | instance Requester t m => Requester t (RouteWriterT t segment m) where 52 | type Request (RouteWriterT t segment m) = Request m 53 | type Response (RouteWriterT t segment m) = Response m 54 | requesting = lift . requesting 55 | requesting_ = lift . requesting_ 56 | 57 | instance RouteWriter t segment m => RouteWriter t segment (RequesterT t request response m) where 58 | tellRoute = lift . tellRoute 59 | 60 | instance Wrapped (RouteWriterT t segment m a) where 61 | type Unwrapped (RouteWriterT t segment m a) = EventWriterT t [segment] m a 62 | _Wrapped' = iso coerce coerce 63 | 64 | instance RouteWriterT t segment m a ~ x => Rewrapped (RouteWriterT t segment m a) x 65 | 66 | instance PerformEvent t m => PerformEvent t (RouteWriterT t segment m) where 67 | type Performable (RouteWriterT t segment m) = Performable m 68 | {-# INLINABLE performEvent_ #-} 69 | performEvent_ = lift . performEvent_ 70 | {-# INLINABLE performEvent #-} 71 | performEvent = lift . performEvent 72 | 73 | instance MonadRef m => MonadRef (RouteWriterT t segment m) where 74 | type Ref (RouteWriterT t segment m) = Ref m 75 | {-# INLINABLE newRef #-} 76 | newRef = lift . newRef 77 | {-# INLINABLE readRef #-} 78 | readRef = lift . readRef 79 | {-# INLINABLE writeRef #-} 80 | writeRef r = lift . writeRef r 81 | 82 | instance (Adjustable t m, MonadHold t m) => Adjustable t (RouteWriterT t segment m) where 83 | runWithReplace a0 a' = RouteWriterT $ runWithReplace (unRouteWriterT a0) (fmapCheap unRouteWriterT a') 84 | traverseDMapWithKeyWithAdjust f dm edm = RouteWriterT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteWriterT $ f k v) (coerce dm) (coerceEvent edm) 85 | {-# INLINABLE traverseDMapWithKeyWithAdjust #-} 86 | traverseDMapWithKeyWithAdjustWithMove f dm edm = RouteWriterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRouteWriterT $ f k v) (coerce dm) (coerceEvent edm) 87 | 88 | instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteWriterT t segment m) where 89 | type DomBuilderSpace (RouteWriterT t segment m) = DomBuilderSpace m 90 | textNode = lift . textNode 91 | element elementTag cfg (RouteWriterT child) = RouteWriterT $ element elementTag cfg child 92 | inputElement = lift . inputElement 93 | textAreaElement = lift . textAreaElement 94 | selectElement cfg (RouteWriterT child) = RouteWriterT $ selectElement cfg child 95 | placeRawElement = lift . placeRawElement 96 | wrapRawElement e = lift . wrapRawElement e 97 | 98 | instance (Monad m, NotReady t m) => NotReady t (RouteWriterT t segment m) 99 | 100 | deriving instance MonadReader r m => MonadReader r (RouteWriterT t segment m) 101 | 102 | instance RouteWriter t segment m => RouteWriter t segment (EventWriterT t w m) where 103 | tellRoute = lift . tellRoute 104 | instance EventWriter t w m => EventWriter t w (RouteWriterT t segment m) where 105 | tellEvent = lift . tellEvent 106 | 107 | instance RouteWriter t segment m => RouteWriter t segment (DynamicWriterT t w m) where 108 | tellRoute = lift . tellRoute 109 | instance DynamicWriter t w m => DynamicWriter t w (RouteWriterT t segment m) where 110 | tellDyn = lift . tellDyn 111 | 112 | 113 | instance HasDocument m => HasDocument (RouteWriterT t segment m) 114 | #ifndef ghcjs_HOST_OS 115 | instance MonadJSM m => MonadJSM (RouteWriterT segment t m) 116 | #endif 117 | 118 | 119 | instance PrimMonad m => PrimMonad (RouteWriterT t segment m) where 120 | type PrimState (RouteWriterT t segment m) = PrimState m 121 | primitive = lift . primitive 122 | 123 | deriving instance HasRoute t segment m => HasRoute t segment (RouteWriterT t segment m) 124 | 125 | --instance HasMountStatus t m => HasMountStatus t (RouteWriterT r segment m) where 126 | -- getMountStatus = lift getMountStatus 127 | 128 | -- | Runs an action that can easily set new routes at will anywhere in the action. 129 | runRouteWriterT :: (Monad m, Reflex t) => RouteWriterT t segment m a -> m (a, Event t [segment]) 130 | runRouteWriterT (RouteWriterT m) = runEventWriterT m 131 | 132 | -- | Sets a new route immediately (on post-build) to the given route. 133 | tellRedirectLocally :: (PostBuild t m, RouteWriter t segment m) => [segment] -> m () 134 | tellRedirectLocally segments = tellRoute =<< redirectLocally segments 135 | 136 | -- | Alias for 'tellRedirectLocally' 137 | localRedirect :: (PostBuild t m, RouteWriter t segment m) => [segment] -> m () 138 | localRedirect = tellRedirectLocally 139 | 140 | 141 | -- | Sets a new route to the given route whenever the given 'Event' fires, ignoring the 'Event' payload. 142 | tellRouteAs :: (RouteWriter t segment m) => [segment] -> Event t a -> m () 143 | tellRouteAs segments ev = tellRoute (segments <$ ev) 144 | 145 | -- | Sets a new route by transforming an arbitrary 'Event' payload into a route. 146 | tellRouteBy :: (RouteWriter t segment m) => (a -> [segment]) -> Event t a -> m () 147 | tellRouteBy toSegments ev = tellRoute (toSegments <$> ev) 148 | 149 | -- | Changes the route with an arbitrary function over the current route. 150 | tellRouteModifyWith 151 | :: (RouteWriter t segment m, HasRoute t segment m, MonadHold t m, MonadFix m, Eq segment) 152 | => Event t ([segment] -> [segment]) -> m () 153 | tellRouteModifyWith ev = do 154 | segments <- allRouteSegments 155 | tellRoute $ attachWith (&) (current segments) ev 156 | 157 | -- | Sets a new route relative to the current layer in the routing hierarchy. 158 | tellRouteRelative 159 | :: (RouteWriter t segment m, HasRoute t segment m, MonadHold t m, MonadFix m, Eq segment) 160 | => Event t [segment] -> m () 161 | tellRouteRelative ev = do 162 | parents <- parentRouteSegments 163 | tellRoute $ attachWith (++) (current parents) ev 164 | 165 | -- Like 'tellRouteAs' and 'tellRouteRelative'. 166 | tellRouteRelativeAs 167 | :: (RouteWriter t segment m, HasRoute t segment m, MonadHold t m, MonadFix m, Eq segment) 168 | => [segment] -> Event t a -> m () 169 | tellRouteRelativeAs segments ev = tellRouteRelative (segments <$ ev) 170 | -------------------------------------------------------------------------------- /reflex-dom-nested-routing.cabal: -------------------------------------------------------------------------------- 1 | name: reflex-dom-nested-routing 2 | version: 0.0.3 3 | synopsis: Nested client-side routing for Reflex-DOM 4 | description: See README at 5 | category: Web 6 | maintainer: Elliot Cameron 7 | copyright: 2017 Elliot Cameron 8 | license: BSD3 9 | license-file: LICENSE 10 | build-type: Simple 11 | cabal-version: >= 1.10 12 | extra-source-files: 13 | CHANGELOG.md 14 | README.md 15 | 16 | 17 | library 18 | hs-source-dirs: . 19 | 20 | ghc-options: 21 | -Wall 22 | -Wincomplete-uni-patterns 23 | -Wincomplete-record-updates 24 | -Wno-unused-do-bind 25 | -O2 26 | build-depends: 27 | base 28 | , bytestring 29 | , exception-transformers 30 | , jsaddle 31 | , lens 32 | , mtl 33 | , primitive 34 | , ref-tf 35 | , reflex 36 | , reflex-dom-core 37 | , reflex-dom-contrib 38 | , text 39 | , uri-bytestring 40 | exposed-modules: 41 | Reflex.Dom.Routing.Nested 42 | Reflex.Dom.Routing.Writer 43 | default-language: Haskell2010 44 | --------------------------------------------------------------------------------