Merge branch 'tysonzero-remove-has-uri-2'

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

@@ -7,25 +7,22 @@ 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
-  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) id $
-          runRoute (Proxy :: Proxy ClientRoutes) handlers m
+      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

@@ -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
@@ -59,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) id result
-    result = runRoute (Proxy :: Proxy API) handlers model
+    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,12 +97,11 @@ 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 app@App{..} = do
-  uri <- getCurrentURI
-  let modelWithUri = setURI uri model
+miso :: Eq model => (URI -> App model action) -> IO ()
+miso f = do
+  app@App {..} <- f <$> getCurrentURI
   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

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 ()
 

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,10 +24,6 @@
 module Miso.Router
   ( runRoute
   , RoutingError (..)
-  , HasURI (..)
-  , getURI
-  , setURI
-  , makeLens
   ) where
 
 import qualified Data.ByteString.Char8 as BS
@@ -42,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.
@@ -145,12 +140,16 @@ runRouteLoc loc layout page m =
 -- 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 m layout
   => Proxy layout
   -> RouteT m layout a
+  -> (m -> URI)
   -> m
   -> Either RoutingError a
-runRoute layout page m = runRouteLoc (uriToLocation (getURI m)) layout page m
+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 -> m -> Either RoutingError a
@@ -195,16 +194,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
-
-
-
-
-