From 2143e99df75d9bf0bea0033900acb2601085281b Mon Sep 17 00:00:00 2001 From: tysonzero Date: Fri, 23 Mar 2018 05:41:10 -0400 Subject: [PATCH 1/3] Remove HasURI completely --- examples/haskell-miso.org/client/Main.hs | 10 +- examples/router/Main.hs | 11 +- ghcjs-src/Miso.hs | 6 +- src/Miso/Router.hs | 124 ++++++++++------------- 4 files changed, 60 insertions(+), 91 deletions(-) diff --git a/examples/haskell-miso.org/client/Main.hs b/examples/haskell-miso.org/client/Main.hs index cd4575aa..c81a9667 100644 --- a/examples/haskell-miso.org/client/Main.hs +++ b/examples/haskell-miso.org/client/Main.hs @@ -7,12 +7,6 @@ import Data.Proxy import Miso import Miso.String -instance HasURI Model where - lensURI = makeLens getter setter - where - getter = uri - setter = \m u -> m { uri = u } - main :: IO () main = do currentURI <- getCurrentURI @@ -24,8 +18,8 @@ main = do events = defaultEvents subs = [ uriSub HandleURI ] view m = - either (const $ the404 m) id $ - runRoute (Proxy :: Proxy ClientRoutes) handlers m + either (const $ the404 m) ($ m) $ + runRoute (Proxy :: Proxy ClientRoutes) handlers currentURI updateModel :: Action -> Model -> Effect Action Model updateModel (HandleURI u) m = m { uri = u } <# do diff --git a/examples/router/Main.hs b/examples/router/Main.hs index fd020eaa..ebfd8e7e 100644 --- a/examples/router/Main.hs +++ b/examples/router/Main.hs @@ -22,13 +22,6 @@ data Model -- ^ current URI of application } deriving (Eq, Show) --- | HasURI typeclass -instance HasURI Model where - lensURI = makeLens getter setter - where - getter = uri - setter = \m u -> m { uri = u } - -- | Action data Action = HandleURI URI @@ -61,8 +54,8 @@ updateModel _ m = noEff m viewModel :: Model -> View Action viewModel model@Model {..} = view where - view = either (const the404) id result - result = runRoute (Proxy :: Proxy API) handlers model + view = either (const the404) ($ model) result + result = runRoute (Proxy :: Proxy API) handlers uri handlers = about :<|> home home (_ :: Model) = div_ [] [ div_ [] [ text "home" ] diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs index 161b75d2..16183033 100644 --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -97,12 +97,10 @@ common App {..} m getView = do -- | Runs an isomorphic miso application -- Assumes the pre-rendered DOM is already present -miso :: (HasURI model, Eq model) => App model action -> IO () +miso :: Eq model => App model action -> IO () miso app@App{..} = do - uri <- getCurrentURI - let modelWithUri = setURI uri model common app model $ \writeEvent -> do - let initialView = view modelWithUri + let initialView = view model VTree (OI.Object iv) <- flip runView writeEvent initialView -- Initial diff can be bypassed, just copy DOM into VTree copyDOMIntoVTree iv diff --git a/src/Miso/Router.hs b/src/Miso/Router.hs index 54a432a4..55595e53 100644 --- a/src/Miso/Router.hs +++ b/src/Miso/Router.hs @@ -24,9 +24,6 @@ module Miso.Router ( runRoute , RoutingError (..) - , HasURI (..) - , getURI - , setURI , makeLens ) where @@ -78,111 +75,111 @@ data Router a where -- It is the class responsible for making API combinators routable. -- 'RouteT' is used to build up the handler types. -- 'Router' is returned, to be interpretted by 'routeLoc'. -class HasRouter model layout where +class HasRouter layout where -- | A route handler. - type RouteT model layout a :: * + type RouteT layout a :: * -- | Transform a route handler into a 'Router'. - route :: Proxy layout -> Proxy a -> RouteT model layout a -> model -> Router a + route :: Proxy layout -> Proxy a -> RouteT layout a -> Router a -- | Alternative -instance (HasRouter m x, HasRouter m y) => HasRouter m (x :<|> y) where - type RouteT m (x :<|> y) a = RouteT m x a :<|> RouteT m y a - route _ (a :: Proxy a) ((x :: RouteT m x a) :<|> (y :: RouteT m y a)) m - = RChoice (route (Proxy :: Proxy x) a x m) (route (Proxy :: Proxy y) a y m) +instance (HasRouter x, HasRouter y) => HasRouter (x :<|> y) where + type RouteT (x :<|> y) a = RouteT x a :<|> RouteT y a + route _ (a :: Proxy a) ((x :: RouteT x a) :<|> (y :: RouteT y a)) + = RChoice (route (Proxy :: Proxy x) a x) (route (Proxy :: Proxy y) a y) -- | Capture -instance (HasRouter m sublayout, FromHttpApiData x) => - HasRouter m (Capture sym x :> sublayout) where - type RouteT m (Capture sym x :> sublayout) a = x -> RouteT m sublayout a - route _ a f m = RCapture (\x -> route (Proxy :: Proxy sublayout) a (f x) m) +instance (HasRouter sublayout, FromHttpApiData x) => + HasRouter (Capture sym x :> sublayout) where + type RouteT (Capture sym x :> sublayout) a = x -> RouteT sublayout a + route _ a f = RCapture (\x -> route (Proxy :: Proxy sublayout) a (f x)) -- | QueryParam -instance (HasRouter m sublayout, FromHttpApiData x, KnownSymbol sym) - => HasRouter m (QueryParam sym x :> sublayout) where - type RouteT m (QueryParam sym x :> sublayout) a = Maybe x -> RouteT m sublayout a - route _ a f m = RQueryParam (Proxy :: Proxy sym) - (\x -> route (Proxy :: Proxy sublayout) a (f x) m) +instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym) + => HasRouter (QueryParam sym x :> sublayout) where + type RouteT (QueryParam sym x :> sublayout) a = Maybe x -> RouteT sublayout a + route _ a f = RQueryParam (Proxy :: Proxy sym) + (\x -> route (Proxy :: Proxy sublayout) a (f x)) -- | QueryParams -instance (HasRouter m sublayout, FromHttpApiData x, KnownSymbol sym) - => HasRouter m (QueryParams sym x :> sublayout) where - type RouteT m (QueryParams sym x :> sublayout) a = [x] -> RouteT m sublayout a - route _ a f m = RQueryParams +instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym) + => HasRouter (QueryParams sym x :> sublayout) where + type RouteT (QueryParams sym x :> sublayout) a = [x] -> RouteT sublayout a + route _ a f = RQueryParams (Proxy :: Proxy sym) - (\x -> route (Proxy :: Proxy sublayout) a (f x) m) + (\x -> route (Proxy :: Proxy sublayout) a (f x)) -- | QueryFlag -instance (HasRouter m sublayout, KnownSymbol sym) - => HasRouter m (QueryFlag sym :> sublayout) where - type RouteT m (QueryFlag sym :> sublayout) a = Bool -> RouteT m sublayout a - route _ a f m = RQueryFlag +instance (HasRouter sublayout, KnownSymbol sym) + => HasRouter (QueryFlag sym :> sublayout) where + type RouteT (QueryFlag sym :> sublayout) a = Bool -> RouteT sublayout a + route _ a f = RQueryFlag (Proxy :: Proxy sym) - (\x -> route (Proxy :: Proxy sublayout) a (f x) m) + (\x -> route (Proxy :: Proxy sublayout) a (f x)) -- | Path -instance (HasRouter m sublayout, KnownSymbol path) - => HasRouter m (path :> sublayout) where - type RouteT m (path :> sublayout) a = RouteT m sublayout a - route _ a page m = RPath +instance (HasRouter sublayout, KnownSymbol path) + => HasRouter (path :> sublayout) where + type RouteT (path :> sublayout) a = RouteT sublayout a + route _ a page = RPath (Proxy :: Proxy path) - (route (Proxy :: Proxy sublayout) a page m) + (route (Proxy :: Proxy sublayout) a page) -- | View -instance HasRouter m (View a) where - type RouteT m (View a) x = m -> x - route _ _ a m = RPage (a m) +instance HasRouter (View a) where + type RouteT (View a) x = x + route _ _ a = RPage a -- | Use a handler to route a 'Location'. -- Normally 'runRoute' should be used instead, unless you want custom -- handling of string failing to parse as 'URI'. -runRouteLoc :: forall m layout a. HasRouter m layout - => Location -> Proxy layout -> RouteT m layout a -> m -> Either RoutingError a -runRouteLoc loc layout page m = - let routing = route layout (Proxy :: Proxy a) page m - in routeLoc loc routing m +runRouteLoc :: forall layout a. HasRouter layout + => Location -> Proxy layout -> RouteT layout a -> Either RoutingError a +runRouteLoc loc layout page = + let routing = route layout (Proxy :: Proxy a) page + in routeLoc loc routing -- | Use a handler to route a location, represented as a 'String'. -- All handlers must, in the end, return @m a@. -- 'routeLoc' will choose a route and return its result. runRoute - :: (HasURI m, HasRouter m layout) + :: HasRouter layout => Proxy layout - -> RouteT m layout a - -> m + -> RouteT layout a + -> URI -> Either RoutingError a -runRoute layout page m = runRouteLoc (uriToLocation (getURI m)) layout page m +runRoute layout page u = runRouteLoc (uriToLocation u) layout page -- | Use a computed 'Router' to route a 'Location'. -routeLoc :: Location -> Router a -> m -> Either RoutingError a -routeLoc loc r m = case r of +routeLoc :: Location -> Router a -> Either RoutingError a +routeLoc loc r = case r of RChoice a b -> do - case routeLoc loc a m of - Left Fail -> routeLoc loc b m + case routeLoc loc a of + Left Fail -> routeLoc loc b Right x -> Right x RCapture f -> case locPath loc of [] -> Left Fail capture:paths -> case parseUrlPieceMaybe capture of Nothing -> Left Fail - Just x -> routeLoc loc { locPath = paths } (f x) m + Just x -> routeLoc loc { locPath = paths } (f x) RQueryParam sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of - Nothing -> routeLoc loc (f Nothing) m + Nothing -> routeLoc loc (f Nothing) Just Nothing -> Left Fail Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of Nothing -> Left Fail - Just x -> routeLoc loc (f (Just x)) m - RQueryParams sym f -> maybe (Left Fail) (\x -> routeLoc loc (f x) m) $ do + Just x -> routeLoc loc (f (Just x)) + RQueryParams sym f -> maybe (Left Fail) (\x -> routeLoc loc (f x)) $ do ps <- sequence $ snd <$> Prelude.filter (\(k, _) -> k == BS.pack (symbolVal sym)) (locQuery loc) sequence $ (parseQueryParamMaybe . decodeUtf8) <$> ps RQueryFlag sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of - Nothing -> routeLoc loc (f False) m - Just Nothing -> routeLoc loc (f True) m + Nothing -> routeLoc loc (f False) + Just Nothing -> routeLoc loc (f True) Just (Just _) -> Left Fail RPath sym a -> case locPath loc of [] -> Left Fail p:paths -> if p == T.pack (symbolVal sym) - then routeLoc (loc { locPath = paths }) a m + then routeLoc (loc { locPath = paths }) a else Left Fail RPage a -> case locPath loc of @@ -195,16 +192,3 @@ uriToLocation uri = Location { locPath = decodePathSegments $ BS.pack (uriPath uri) , locQuery = parseQuery $ BS.pack (uriQuery uri) } - -class HasURI m where lensURI :: Lens' m URI - -getURI :: HasURI m => m -> URI -getURI = get lensURI - -setURI :: HasURI m => URI -> m -> m -setURI m u = set lensURI m u - - - - - From 1dba0b8e599ace6e1b5080cc3b7dad1ec44065a1 Mon Sep 17 00:00:00 2001 From: Robert Fischer Date: Wed, 21 Feb 2018 13:23:52 -0500 Subject: [PATCH 2/3] Use window.location.href to get the current URI --- ghcjs-src/Miso/Subscription/History.hs | 44 ++++++++++---------------- 1 file changed, 17 insertions(+), 27 deletions(-) diff --git a/ghcjs-src/Miso/Subscription/History.hs b/ghcjs-src/Miso/Subscription/History.hs index aea60601..915c8098 100644 --- a/ghcjs-src/Miso/Subscription/History.hs +++ b/ghcjs-src/Miso/Subscription/History.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Miso.Subscription.History @@ -23,14 +23,14 @@ module Miso.Subscription.History , URI (..) ) where -import Control.Concurrent -import Control.Monad -import GHCJS.Foreign.Callback -import Miso.Concurrent -import Miso.Html.Internal ( Sub ) -import Miso.String -import Network.URI hiding (path) -import System.IO.Unsafe +import Control.Concurrent +import Control.Monad +import GHCJS.Foreign.Callback +import Miso.Concurrent +import Miso.Html.Internal (Sub) +import Miso.String +import Network.URI hiding (path) +import System.IO.Unsafe -- | Retrieves current URI of page getCurrentURI :: IO URI @@ -41,11 +41,10 @@ getCurrentURI = getURI getURI :: IO URI {-# INLINE getURI #-} getURI = do - URI <$> do unpack <$> getProtocol - <*> pure Nothing - <*> do Prelude.drop 1 . unpack <$> getPathName - <*> do unpack <$> getSearch - <*> do unpack <$> getHash + href <- fromMisoString <$> getWindowLocationHref + case parseURI href of + Nothing -> fail $ "Could not parse URI from window.location: " ++ href + Just uri -> return uri -- | Pushes a new URI onto the History stack pushURI :: URI -> IO () @@ -92,6 +91,9 @@ uriSub = \f sink -> do asyncCallback $ do sink =<< f <$> getURI +foreign import javascript safe "$r = window.location.href || '';" + getWindowLocationHref :: IO MisoString + foreign import javascript unsafe "window.history.go($1);" go' :: Int -> IO () @@ -101,18 +103,6 @@ foreign import javascript unsafe "window.history.back();" foreign import javascript unsafe "window.history.forward();" forward' :: IO () -foreign import javascript unsafe "$r = window.location.pathname;" - getPathName :: IO JSString - -foreign import javascript unsafe "$r = window.location.search;" - getSearch :: IO JSString - -foreign import javascript unsafe "$r = window.location.hash;" - getHash :: IO JSString - -foreign import javascript unsafe "$r = window.location.protocol;" - getProtocol :: IO JSString - foreign import javascript unsafe "window.addEventListener('popstate', $1);" onPopState :: Callback (IO ()) -> IO () From 33de70c3e708c6bf1e7f04ffd7f962187754ec1c Mon Sep 17 00:00:00 2001 From: David Johnson Date: Mon, 26 Mar 2018 01:41:01 +0000 Subject: [PATCH 3/3] Remove Miso.Lens, pass URI to miso function --- examples/compose-update/Main.hs | 2 +- examples/haskell-miso.org/client/Main.hs | 15 +-- examples/haskell-miso.org/shared/Common.hs | 4 - examples/router/Main.hs | 7 +- examples/sse/client/Main.hs | 28 +++-- ghcjs-src/Miso.hs | 5 +- miso.cabal | 1 - src/Miso/Lens.hs | 34 ------ src/Miso/Router.hs | 114 +++++++++++---------- 9 files changed, 87 insertions(+), 123 deletions(-) delete mode 100644 src/Miso/Lens.hs diff --git a/examples/compose-update/Main.hs b/examples/compose-update/Main.hs index 766c0d80..99e43526 100644 --- a/examples/compose-update/Main.hs +++ b/examples/compose-update/Main.hs @@ -13,7 +13,6 @@ import Control.Monad import Data.Monoid import Miso -import Miso.Lens import Miso.String -- In this slightly contrived example, our model consists of two @@ -32,6 +31,7 @@ data Action -- utilities ourselves. We recommend that in your own applications, -- you depend on a lens library such as @lens@ or @microlens@ to get -- these definitions. +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t -- | You can find this under the same name in @lens@ and -- @microlens@. @lens@ also provides the infix operator '%%~' as a diff --git a/examples/haskell-miso.org/client/Main.hs b/examples/haskell-miso.org/client/Main.hs index c81a9667..3630e681 100644 --- a/examples/haskell-miso.org/client/Main.hs +++ b/examples/haskell-miso.org/client/Main.hs @@ -8,18 +8,21 @@ import Miso import Miso.String main :: IO () -main = do - currentURI <- getCurrentURI - miso App { model = Model currentURI False, ..} +main = miso $ \currentURI -> App + { model = Model currentURI False + , view = viewModel + , .. + } where initialAction = NoOp mountPoint = Nothing update = updateModel events = defaultEvents subs = [ uriSub HandleURI ] - view m = - either (const $ the404 m) ($ m) $ - runRoute (Proxy :: Proxy ClientRoutes) handlers currentURI + viewModel m = + case runRoute (Proxy :: Proxy ClientRoutes) handlers uri m of + Left _ -> the404 m + Right v -> v updateModel :: Action -> Model -> Effect Action Model updateModel (HandleURI u) m = m { uri = u } <# do diff --git a/examples/haskell-miso.org/shared/Common.hs b/examples/haskell-miso.org/shared/Common.hs index 9885820d..e82fb1a3 100644 --- a/examples/haskell-miso.org/shared/Common.hs +++ b/examples/haskell-miso.org/shared/Common.hs @@ -45,10 +45,6 @@ type ClientRoutes = Examples :<|> Home -- | Handlers -handlers :: - (Model -> View Action) - :<|> ((Model -> View Action) - :<|> ((Model -> View Action) :<|> (Model -> View Action))) handlers = examples :<|> docs :<|> community diff --git a/examples/router/Main.hs b/examples/router/Main.hs index ebfd8e7e..390e6ddb 100644 --- a/examples/router/Main.hs +++ b/examples/router/Main.hs @@ -52,10 +52,11 @@ updateModel _ m = noEff m -- | View function, with routing viewModel :: Model -> View Action -viewModel model@Model {..} = view +viewModel model = view where - view = either (const the404) ($ model) result - result = runRoute (Proxy :: Proxy API) handlers uri + view = + either (const the404) id + $ runRoute (Proxy :: Proxy API) handlers uri model handlers = about :<|> home home (_ :: Model) = div_ [] [ div_ [] [ text "home" ] diff --git a/examples/sse/client/Main.hs b/examples/sse/client/Main.hs index d0142cf2..6b6a6a4a 100644 --- a/examples/sse/client/Main.hs +++ b/examples/sse/client/Main.hs @@ -7,26 +7,22 @@ import Data.Proxy import Miso --- 'runRoute' requires that our model includes the current URI. -instance HasURI Model where - lensURI = makeLens getter setter - where - getter = modelUri - setter = \m u -> m { modelUri = u } - main :: IO () main = do - currentURI <- getCurrentURI - miso - App {initialAction = NoOp, model = Model currentURI "No event received", ..} + miso $ \currentURI -> + App { initialAction = NoOp + , model = Model currentURI "No event received" + , .. + } where update = updateModel - view - -- If 'runRoute' fails, we fall back to displaying a 404 page. - = - either (const the404) id . runRoute (Proxy :: Proxy ClientRoutes) handlers + view m = case runRoute (Proxy :: Proxy ClientRoutes) handlers modelUri m of + Left _ -> the404 + Right m -> m events = defaultEvents - subs = [sseSub "/sse" handleSseMsg, uriSub HandleURI] + subs = [ sseSub "/sse" handleSseMsg + , uriSub HandleURI + ] mountPoint = Nothing handleSseMsg :: SSE String -> Action @@ -35,7 +31,7 @@ handleSseMsg SSEClose = ServerMsg "SSE connection closed" handleSseMsg SSEError = ServerMsg "SSE error" updateModel :: Action -> Model -> Effect Action Model -updateModel (ServerMsg msg) m = noEff (m {modelMsg = "Event received: " ++ msg}) +updateModel (ServerMsg msg) m = pure (m {modelMsg = "Event received: " ++ msg}) updateModel (HandleURI u) m = m {modelUri = u} <# pure NoOp updateModel (ChangeURI u) m = m <# (pushURI u >> pure NoOp) updateModel NoOp m = noEff m diff --git a/ghcjs-src/Miso.hs b/ghcjs-src/Miso.hs index 16183033..d8cfd3aa 100644 --- a/ghcjs-src/Miso.hs +++ b/ghcjs-src/Miso.hs @@ -97,8 +97,9 @@ common App {..} m getView = do -- | Runs an isomorphic miso application -- Assumes the pre-rendered DOM is already present -miso :: Eq model => App model action -> IO () -miso app@App{..} = do +miso :: Eq model => (URI -> App model action) -> IO () +miso f = do + app@App {..} <- f <$> getCurrentURI common app model $ \writeEvent -> do let initialView = view model VTree (OI.Object iv) <- flip runView writeEvent initialView diff --git a/miso.cabal b/miso.cabal index 32ebb2d3..447ba182 100644 --- a/miso.cabal +++ b/miso.cabal @@ -255,7 +255,6 @@ library Miso.Html.Element Miso.Html.Event Miso.Html.Property - Miso.Lens Miso.Event Miso.Event.Decoder Miso.Event.Types diff --git a/src/Miso/Lens.hs b/src/Miso/Lens.hs deleted file mode 100644 index e270e682..00000000 --- a/src/Miso/Lens.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Miso.Lens --- Copyright : (C) 2016-2018 David M. Johnson --- License : BSD3-style (see the file LICENSE) --- Maintainer : David M. Johnson --- Stability : experimental --- Portability : non-portable ----------------------------------------------------------------------------- -module Miso.Lens - ( Lens - , Lens' - , Getting - , get - , set - , makeLens - ) where - -import Data.Functor.Identity -import Control.Applicative - -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t -type Lens' s a = Lens s s a a -type Getting r s a = (a -> Const r a) -> (s -> Const r s) - -get :: Getting a s a -> s -> a -get l = \ s -> getConst (l Const s) - -set :: Lens s t a b -> b -> s -> t -set l b = \s -> runIdentity (l (\ _ -> pure b) s) - -makeLens :: (s -> a) -> (s -> b -> t) -> Lens s t a b -makeLens get' upd = \ f s -> upd s `fmap` f (get' s) diff --git a/src/Miso/Router.hs b/src/Miso/Router.hs index 55595e53..359fa6fd 100644 --- a/src/Miso/Router.hs +++ b/src/Miso/Router.hs @@ -24,7 +24,6 @@ module Miso.Router ( runRoute , RoutingError (..) - , makeLens ) where import qualified Data.ByteString.Char8 as BS @@ -39,7 +38,6 @@ import Servant.API import Web.HttpApiData import Miso.Html hiding (text) -import Miso.Lens -- | Router terminator. -- The 'HasRouter' instance for 'View' finalizes the router. @@ -75,111 +73,115 @@ data Router a where -- It is the class responsible for making API combinators routable. -- 'RouteT' is used to build up the handler types. -- 'Router' is returned, to be interpretted by 'routeLoc'. -class HasRouter layout where +class HasRouter model layout where -- | A route handler. - type RouteT layout a :: * + type RouteT model layout a :: * -- | Transform a route handler into a 'Router'. - route :: Proxy layout -> Proxy a -> RouteT layout a -> Router a + route :: Proxy layout -> Proxy a -> RouteT model layout a -> model -> Router a -- | Alternative -instance (HasRouter x, HasRouter y) => HasRouter (x :<|> y) where - type RouteT (x :<|> y) a = RouteT x a :<|> RouteT y a - route _ (a :: Proxy a) ((x :: RouteT x a) :<|> (y :: RouteT y a)) - = RChoice (route (Proxy :: Proxy x) a x) (route (Proxy :: Proxy y) a y) +instance (HasRouter m x, HasRouter m y) => HasRouter m (x :<|> y) where + type RouteT m (x :<|> y) a = RouteT m x a :<|> RouteT m y a + route _ (a :: Proxy a) ((x :: RouteT m x a) :<|> (y :: RouteT m y a)) m + = RChoice (route (Proxy :: Proxy x) a x m) (route (Proxy :: Proxy y) a y m) -- | Capture -instance (HasRouter sublayout, FromHttpApiData x) => - HasRouter (Capture sym x :> sublayout) where - type RouteT (Capture sym x :> sublayout) a = x -> RouteT sublayout a - route _ a f = RCapture (\x -> route (Proxy :: Proxy sublayout) a (f x)) +instance (HasRouter m sublayout, FromHttpApiData x) => + HasRouter m (Capture sym x :> sublayout) where + type RouteT m (Capture sym x :> sublayout) a = x -> RouteT m sublayout a + route _ a f m = RCapture (\x -> route (Proxy :: Proxy sublayout) a (f x) m) -- | QueryParam -instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym) - => HasRouter (QueryParam sym x :> sublayout) where - type RouteT (QueryParam sym x :> sublayout) a = Maybe x -> RouteT sublayout a - route _ a f = RQueryParam (Proxy :: Proxy sym) - (\x -> route (Proxy :: Proxy sublayout) a (f x)) +instance (HasRouter m sublayout, FromHttpApiData x, KnownSymbol sym) + => HasRouter m (QueryParam sym x :> sublayout) where + type RouteT m (QueryParam sym x :> sublayout) a = Maybe x -> RouteT m sublayout a + route _ a f m = RQueryParam (Proxy :: Proxy sym) + (\x -> route (Proxy :: Proxy sublayout) a (f x) m) -- | QueryParams -instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym) - => HasRouter (QueryParams sym x :> sublayout) where - type RouteT (QueryParams sym x :> sublayout) a = [x] -> RouteT sublayout a - route _ a f = RQueryParams +instance (HasRouter m sublayout, FromHttpApiData x, KnownSymbol sym) + => HasRouter m (QueryParams sym x :> sublayout) where + type RouteT m (QueryParams sym x :> sublayout) a = [x] -> RouteT m sublayout a + route _ a f m = RQueryParams (Proxy :: Proxy sym) - (\x -> route (Proxy :: Proxy sublayout) a (f x)) + (\x -> route (Proxy :: Proxy sublayout) a (f x) m) -- | QueryFlag -instance (HasRouter sublayout, KnownSymbol sym) - => HasRouter (QueryFlag sym :> sublayout) where - type RouteT (QueryFlag sym :> sublayout) a = Bool -> RouteT sublayout a - route _ a f = RQueryFlag +instance (HasRouter m sublayout, KnownSymbol sym) + => HasRouter m (QueryFlag sym :> sublayout) where + type RouteT m (QueryFlag sym :> sublayout) a = Bool -> RouteT m sublayout a + route _ a f m = RQueryFlag (Proxy :: Proxy sym) - (\x -> route (Proxy :: Proxy sublayout) a (f x)) + (\x -> route (Proxy :: Proxy sublayout) a (f x) m) -- | Path -instance (HasRouter sublayout, KnownSymbol path) - => HasRouter (path :> sublayout) where - type RouteT (path :> sublayout) a = RouteT sublayout a - route _ a page = RPath +instance (HasRouter m sublayout, KnownSymbol path) + => HasRouter m (path :> sublayout) where + type RouteT m (path :> sublayout) a = RouteT m sublayout a + route _ a page m = RPath (Proxy :: Proxy path) - (route (Proxy :: Proxy sublayout) a page) + (route (Proxy :: Proxy sublayout) a page m) -- | View -instance HasRouter (View a) where - type RouteT (View a) x = x - route _ _ a = RPage a +instance HasRouter m (View a) where + type RouteT m (View a) x = m -> x + route _ _ a m = RPage (a m) -- | Use a handler to route a 'Location'. -- Normally 'runRoute' should be used instead, unless you want custom -- handling of string failing to parse as 'URI'. -runRouteLoc :: forall layout a. HasRouter layout - => Location -> Proxy layout -> RouteT layout a -> Either RoutingError a -runRouteLoc loc layout page = - let routing = route layout (Proxy :: Proxy a) page - in routeLoc loc routing +runRouteLoc :: forall m layout a. HasRouter m layout + => Location -> Proxy layout -> RouteT m layout a -> m -> Either RoutingError a +runRouteLoc loc layout page m = + let routing = route layout (Proxy :: Proxy a) page m + in routeLoc loc routing m -- | Use a handler to route a location, represented as a 'String'. -- All handlers must, in the end, return @m a@. -- 'routeLoc' will choose a route and return its result. runRoute - :: HasRouter layout + :: HasRouter m layout => Proxy layout - -> RouteT layout a - -> URI + -> RouteT m layout a + -> (m -> URI) + -> m -> Either RoutingError a -runRoute layout page u = runRouteLoc (uriToLocation u) layout page +runRoute layout page getURI m = + runRouteLoc (uriToLocation uri) layout page m + where + uri = getURI m -- | Use a computed 'Router' to route a 'Location'. -routeLoc :: Location -> Router a -> Either RoutingError a -routeLoc loc r = case r of +routeLoc :: Location -> Router a -> m -> Either RoutingError a +routeLoc loc r m = case r of RChoice a b -> do - case routeLoc loc a of - Left Fail -> routeLoc loc b + case routeLoc loc a m of + Left Fail -> routeLoc loc b m Right x -> Right x RCapture f -> case locPath loc of [] -> Left Fail capture:paths -> case parseUrlPieceMaybe capture of Nothing -> Left Fail - Just x -> routeLoc loc { locPath = paths } (f x) + Just x -> routeLoc loc { locPath = paths } (f x) m RQueryParam sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of - Nothing -> routeLoc loc (f Nothing) + Nothing -> routeLoc loc (f Nothing) m Just Nothing -> Left Fail Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of Nothing -> Left Fail - Just x -> routeLoc loc (f (Just x)) - RQueryParams sym f -> maybe (Left Fail) (\x -> routeLoc loc (f x)) $ do + Just x -> routeLoc loc (f (Just x)) m + RQueryParams sym f -> maybe (Left Fail) (\x -> routeLoc loc (f x) m) $ do ps <- sequence $ snd <$> Prelude.filter (\(k, _) -> k == BS.pack (symbolVal sym)) (locQuery loc) sequence $ (parseQueryParamMaybe . decodeUtf8) <$> ps RQueryFlag sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of - Nothing -> routeLoc loc (f False) - Just Nothing -> routeLoc loc (f True) + Nothing -> routeLoc loc (f False) m + Just Nothing -> routeLoc loc (f True) m Just (Just _) -> Left Fail RPath sym a -> case locPath loc of [] -> Left Fail p:paths -> if p == T.pack (symbolVal sym) - then routeLoc (loc { locPath = paths }) a + then routeLoc (loc { locPath = paths }) a m else Left Fail RPage a -> case locPath loc of