@@ -7,15 +7,11 @@
77{-# LANGUAGE FlexibleContexts #-}
88{-# LANGUAGE FlexibleInstances #-}
99{-# LANGUAGE GADTs #-}
10−{-# LANGUAGE KindSignatures #-}
1110{-# LANGUAGE LambdaCase #-}
12−{-# LANGUAGE MultiParamTypeClasses #-}
1311{-# LANGUAGE OverloadedStrings #-}
1412{-# LANGUAGE PatternSynonyms #-}
1513{-# LANGUAGE RankNTypes #-}
1614{-# LANGUAGE ScopedTypeVariables #-}
17−{-# LANGUAGE TemplateHaskell #-}
18−{-# LANGUAGE TupleSections #-}
1915{-# LANGUAGE TypeFamilies #-}
2016{-# LANGUAGE TypeOperators #-}
2117{-# LANGUAGE ViewPatterns #-}
@@ -64,7 +60,7 @@ import Prelude hiding ((.), id)
6460import Obelisk.Route
6561
6662import Control.Category (Category (..), (.))
67−import Control.Category.Cartesian
63+import Control.Category.Cartesian ((&&&))
6864import Control.Lens hiding (Bifunctor, bimap, universe, element)
6965import Control.Monad ((<=<))
7066import Control.Monad.Fix
@@ -94,7 +90,9 @@ import Reflex.Dom.Builder.Class
9490import Data.Type.Coercion
9591import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can also be routed
9692import Reflex.Dom.Core
93+import qualified GHCJS.DOM as DOM
9794import qualified GHCJS.DOM.Types as DOM
95+import qualified GHCJS.DOM.Window as Window
9896import Network.URI
9997import Data.Maybe (fromMaybe)
10098import qualified Data.List as L
@@ -511,59 +509,125 @@ runRouteViewT routeEncoder switchover useHash a = do
511509-- | A link widget that, when clicked, sets the route to the provided route. In non-javascript
512510-- contexts, this widget falls back to using @href@s to control navigation
513511routeLink
514− :: forall t m a route.
512+ :: forall t m a route js.
515513 ( DomBuilder t m
516514 , RouteToUrl route m
517515 , SetRoute t route m
516+ , Prerender js t m
518517 )
519518 => route -- ^ Target route
520519 -> m a -- ^ Child widget
521520 -> m a
522521routeLink r w = do
522+ (e, a) <- routeLinkImpl r w
523+ scrollToTop e
524+ return a
525+
526+-- | Raw implementation of 'routeLink'. Does not scroll to the top of the page on clicks.
527+routeLinkImpl
528+ :: forall t m a route.
529+ ( DomBuilder t m
530+ , RouteToUrl route m
531+ , SetRoute t route m
532+ )
533+ => route -- ^ Target route
534+ -> m a -- ^ Child widget
535+ -> m (Event t (), a)
536+routeLinkImpl r w = do
523537 enc <- askRouteToUrl
524538 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
525539 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
526540 & elementConfig_initialAttributes .~ "href" =: enc r
527541 (e, a) <- element "a" cfg w
528542 setRoute $ r <$ domEvent Click e
529− return a
543+ return (domEvent Click e, a)
544+
545+scrollToTop :: forall m t js. (Prerender js t m, Monad m) => Event t () -> m ()
546+scrollToTop e = prerender_ blank $ performEvent_ $ ffor e $ \_ -> liftJSM $ DOM.currentWindow >>= \case
547+ Nothing -> pure ()
548+ Just win -> Window.scrollTo win 0 0
530549
531550-- | Like 'routeLinkDynAttr' but without custom attributes.
532551dynRouteLink
533− :: forall t m a route.
552+ :: forall t m a route js.
534553 ( DomBuilder t m
535554 , PostBuild t m
536− , RouteToUrl (R route) m
537− , SetRoute t (R route) m
555+ , RouteToUrl route m
556+ , SetRoute t route m
557+ , Prerender js t m
538558 )
539− => Dynamic t (R route) -- ^ Target route
540− -> m a -- ^ Child widget of the @a@ element
559+ => Dynamic t route -- ^ Target route
560+ -> m a -- ^ Child widget
541561 -> m a
542−dynRouteLink = routeLinkDynAttr mempty
562+dynRouteLink r w = do
563+ (e, a) <- dynRouteLinkImpl r w
564+ scrollToTop e
565+ return a
566+
567+-- | Raw implementation of 'dynRouteLink'. Does not scroll to the top of the page on clicks.
568+dynRouteLinkImpl
569+ :: forall t m a route.
570+ ( DomBuilder t m
571+ , PostBuild t m
572+ , RouteToUrl route m
573+ , SetRoute t route m
574+ )
575+ => Dynamic t route -- ^ Target route
576+ -> m a -- ^ Child widget
577+ -> m (Event t (), a)
578+dynRouteLinkImpl dr w = do
579+ enc <- askRouteToUrl
580+ er <- dynamicAttributesToModifyAttributes $ ("href" =:) . enc <$> dr
581+ let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
582+ & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
583+ & elementConfig_modifyAttributes .~ er
584+ (e, a) <- element "a" cfg w
585+ let clk = domEvent Click e
586+ setRoute $ tag (current dr) clk
587+ return (clk, a)
543588
544589-- | An @a@-tag link widget that, when clicked, sets the route to current value of the
545590-- provided dynamic route. In non-JavaScript contexts the value of the dynamic post
546591-- build is used so the link still works like 'routeLink'.
547592routeLinkDynAttr
548− :: forall t m a route.
593+ :: forall t m a route js.
549594 ( DomBuilder t m
550595 , PostBuild t m
551596 , RouteToUrl (R route) m
552597 , SetRoute t (R route) m
598+ , Prerender js t m
553599 )
554600 => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored
555601 -> Dynamic t (R route) -- ^ Target route
556602 -> m a -- ^ Child widget of the @a@ element
557603 -> m a
558604routeLinkDynAttr dAttr dr w = do
605+ (e, a) <- routeLinkDynAttrImpl dAttr dr w
606+ scrollToTop e
607+ return a
608+
609+-- | Raw implementation of 'routeLinkDynAttr'. Does not scroll to the top of the page on clicks.
610+routeLinkDynAttrImpl
611+ :: forall t m a route.
612+ ( DomBuilder t m
613+ , PostBuild t m
614+ , RouteToUrl (R route) m
615+ , SetRoute t (R route) m
616+ )
617+ => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored
618+ -> Dynamic t (R route) -- ^ Target route
619+ -> m a -- ^ Child widget of the @a@ element
620+ -> m (Event t (), a)
621+routeLinkDynAttrImpl dAttr dr w = do
559622 enc <- askRouteToUrl
560623 er <- dynamicAttributesToModifyAttributes $ zipDynWith (<>) (("href" =:) . enc <$> dr) dAttr
561624 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
562625 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
563626 & elementConfig_modifyAttributes .~ er
564627 (e, a) <- element "a" cfg w
565− setRoute $ tag (current dr) $ domEvent Click e
566− return a
628+ let clk = domEvent Click e
629+ setRoute $ tag (current dr) clk
630+ return (clk, a)
567631
568632-- On ios due to sandboxing when loading the page from a file adapt the
569633-- path to be based on the hash.