@@ -7,15 +7,11 @@
7{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GADTs #-}
10−{-# LANGUAGE KindSignatures #-}
11{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE LambdaCase #-}
12−{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE OverloadedStrings #-}
14{-# LANGUAGE PatternSynonyms #-}
12{-# LANGUAGE PatternSynonyms #-}
15{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RankNTypes #-}
16{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE ScopedTypeVariables #-}
17−{-# LANGUAGE TemplateHaskell #-}
18−{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeFamilies #-}
20{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE TypeOperators #-}
21{-# LANGUAGE ViewPatterns #-}
17{-# LANGUAGE ViewPatterns #-}
@@ -64,7 +60,7 @@ import Prelude hiding ((.), id)
64import Obelisk.Route
60import Obelisk.Route
66import Control.Category (Category (..), (.))
62import Control.Category (Category (..), (.))
67−import Control.Category.Cartesian
63+import Control.Category.Cartesian ((&&&))
68import Control.Lens hiding (Bifunctor, bimap, universe, element)
64import Control.Lens hiding (Bifunctor, bimap, universe, element)
69import Control.Monad ((<=<))
65import Control.Monad ((<=<))
70import Control.Monad.Fix
66import Control.Monad.Fix
@@ -94,7 +90,9 @@ import Reflex.Dom.Builder.Class
94import Data.Type.Coercion
90import Data.Type.Coercion
95import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can also be routed
91import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can also be routed
96import Reflex.Dom.Core
92import Reflex.Dom.Core
93+import qualified GHCJS.DOM as DOM
97import qualified GHCJS.DOM.Types as DOM
94import qualified GHCJS.DOM.Types as DOM
95+import qualified GHCJS.DOM.Window as Window
98import Network.URI
96import Network.URI
99import Data.Maybe (fromMaybe)
97import Data.Maybe (fromMaybe)
100import qualified Data.List as L
98import qualified Data.List as L
@@ -511,59 +509,125 @@ runRouteViewT routeEncoder switchover useHash a = do
511-- | A link widget that, when clicked, sets the route to the provided route. In non-javascript
509-- | A link widget that, when clicked, sets the route to the provided route. In non-javascript
512-- contexts, this widget falls back to using @href@s to control navigation
510-- contexts, this widget falls back to using @href@s to control navigation
514− :: forall t m a route.
512+ :: forall t m a route js.
515 ( DomBuilder t m
513 ( DomBuilder t m
516 , RouteToUrl route m
514 , RouteToUrl route m
517 , SetRoute t route m
515 , SetRoute t route m
519 => route -- ^ Target route
518 => route -- ^ Target route
520 -> m a -- ^ Child widget
519 -> m a -- ^ Child widget
522routeLink r w = do
521routeLink r w = do
522+ (e, a) <- routeLinkImpl r w
526+-- | Raw implementation of 'routeLink'. Does not scroll to the top of the page on clicks.
528+ :: forall t m a route.
530+ , RouteToUrl route m
531+ , SetRoute t route m
533+ => route -- ^ Target route
534+ -> m a -- ^ Child widget
535+ -> m (Event t (), a)
536+routeLinkImpl r w = do
523 enc <- askRouteToUrl
537 enc <- askRouteToUrl
524 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
538 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
525 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
539 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
526 & elementConfig_initialAttributes .~ "href" =: enc r
540 & elementConfig_initialAttributes .~ "href" =: enc r
527 (e, a) <- element "a" cfg w
541 (e, a) <- element "a" cfg w
528 setRoute $ r <$ domEvent Click e
542 setRoute $ r <$ domEvent Click e
529− return a
543+ return (domEvent Click e, a)
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
548+ Just win -> Window.scrollTo win 0 0
531-- | Like 'routeLinkDynAttr' but without custom attributes.
550-- | Like 'routeLinkDynAttr' but without custom attributes.
532dynRouteLink
551dynRouteLink
533− :: forall t m a route.
552+ :: forall t m a route js.
534 ( DomBuilder t m
553 ( DomBuilder t m
535 , PostBuild t m
554 , PostBuild t m
536− , RouteToUrl (R route) m
555+ , RouteToUrl route m
537− , SetRoute t (R route) m
556+ , SetRoute t route m
539− => Dynamic t (R route) -- ^ Target route
559+ => Dynamic t route -- ^ Target route
540− -> m a -- ^ Child widget of the @a@ element
560+ -> m a -- ^ Child widget
542−dynRouteLink = routeLinkDynAttr mempty
562+dynRouteLink r w = do
563+ (e, a) <- dynRouteLinkImpl r w
567+-- | Raw implementation of 'dynRouteLink'. Does not scroll to the top of the page on clicks.
569+ :: forall t m a route.
572+ , RouteToUrl route m
573+ , SetRoute t route m
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
544-- | An @a@-tag link widget that, when clicked, sets the route to current value of the
589-- | An @a@-tag link widget that, when clicked, sets the route to current value of the
545-- provided dynamic route. In non-JavaScript contexts the value of the dynamic post
590-- provided dynamic route. In non-JavaScript contexts the value of the dynamic post
546-- build is used so the link still works like 'routeLink'.
591-- build is used so the link still works like 'routeLink'.
547routeLinkDynAttr
592routeLinkDynAttr
548− :: forall t m a route.
593+ :: forall t m a route js.
549 ( DomBuilder t m
594 ( DomBuilder t m
550 , PostBuild t m
595 , PostBuild t m
551 , RouteToUrl (R route) m
596 , RouteToUrl (R route) m
552 , SetRoute t (R route) m
597 , SetRoute t (R route) m
554 => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored
600 => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored
555 -> Dynamic t (R route) -- ^ Target route
601 -> Dynamic t (R route) -- ^ Target route
556 -> m a -- ^ Child widget of the @a@ element
602 -> m a -- ^ Child widget of the @a@ element
558routeLinkDynAttr dAttr dr w = do
604routeLinkDynAttr dAttr dr w = do
605+ (e, a) <- routeLinkDynAttrImpl dAttr dr w
609+-- | Raw implementation of 'routeLinkDynAttr'. Does not scroll to the top of the page on clicks.
611+ :: forall t m a route.
614+ , RouteToUrl (R route) m
615+ , SetRoute t (R route) m
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
559 enc <- askRouteToUrl
622 enc <- askRouteToUrl
560 er <- dynamicAttributesToModifyAttributes $ zipDynWith (<>) (("href" =:) . enc <$> dr) dAttr
623 er <- dynamicAttributesToModifyAttributes $ zipDynWith (<>) (("href" =:) . enc <$> dr) dAttr
561 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
624 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
562 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
625 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
563 & elementConfig_modifyAttributes .~ er
626 & elementConfig_modifyAttributes .~ er
564 (e, a) <- element "a" cfg w
627 (e, a) <- element "a" cfg w
628+ let clk = domEvent Click e
565− setRoute $ tag (current dr) $ domEvent Click e
629+ setRoute $ tag (current dr) clk
566− return a
630+ return (clk, a)
568-- On ios due to sandboxing when loading the page from a file adapt the
632-- On ios due to sandboxing when loading the page from a file adapt the
569-- path to be based on the hash.
633-- path to be based on the hash.