Remove Miso.Lens, pass URI to miso function

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

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

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

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" ]

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

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

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

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