Link eff (#4)

* Use URL type from DOM.HTML.History

* LinkProps

* a newtype
* add action field

Rename `goTo` to `goto`.

* Update tests.

* Review the link class

Do not create react class as a function (this is an anti pattern).

* Change link and link' functions.

* Fixed bower.json

Author: Marcin Szamotulski

bower.json

@@ -36,8 +36,5 @@
   "devDependencies": {
     "purescript-psci-support": "^3.0.0",
     "purescript-test-unit": "^13.0.0"
-  },
-  "resolutions": {
-    "purescript-react": "^4.0.0"
   }
 }

example/Main.purs

@@ -6,6 +6,7 @@ import Control.Comonad.Cofree ((:<))
 import Control.Monad.Eff (Eff)
 import DOM (DOM)
 import DOM.HTML (window)
+import DOM.HTML.History (URL(..))
 import DOM.HTML.Types (htmlDocumentToDocument)
 import DOM.HTML.Window (document)
 import DOM.Node.NonElementParentNode (getElementById)
@@ -18,6 +19,7 @@ import Partial.Unsafe (unsafePartial)
 import React (ReactClass, ReactElement, createClass, createElement, getChildren, getProps, spec)
 import React.DOM (div', h1', h2', h3', h4', text)
 import React.Router (IndexRoute(..), Route(..), RouteProps(..), Router, browserRouterClass, defaultConfig, link', (:+))
+import React.Router.Utils (showLocation)
 import ReactDOM (render)
 import Routing.Match.Class (int, lit, str)
 
@@ -37,7 +39,7 @@ home = createClass $ (spec unit render) { displayName = "Home" }
     render this = do
       chrn <- getChildren this
       pure $ div'
-        [ h1' [ link' defaultConfig (show Home) [text "Home component"] ] 
+        [ h1' [ link' defaultConfig (showLocation (Home : Nil)) [text "Home component"] ] 
         , div' chrn
         ]
 
@@ -47,9 +49,9 @@ usersIndex = createClass $ (spec unit render) { displayName = "UsersIndex" }
     render this = do
       pure $ div'
         [ h2' [ text "UserIndex component" ]
-        , div' [ div' [link' defaultConfig "/1" [ text "User 1" ]]
-               , div' [link' defaultConfig "/2" [ text "User 2" ]]
-               , div' [link' defaultConfig "/3" [ text "User 3" ]]
+        , div' [ div' [link' defaultConfig (URL "/1") [ text "User 1" ]]
+               , div' [link' defaultConfig (URL "/2") [ text "User 2" ]]
+               , div' [link' defaultConfig (URL "/3") [ text "User 3" ]]
                ]
         ]
 
@@ -80,11 +82,11 @@ userBooksIndex = createClass $ (spec unit render) { displayName = "UserBooksInde
               _ -> 0
       chrn <- getChildren this
       pure $ div'
-        [ h3' [ link' defaultConfig ("/" <> show uID) [ text "UserBooksIndex component" ] ]
+        [ h3' [ link' defaultConfig (URL $ "/" <> show uID) [ text "UserBooksIndex component" ] ]
         , div'
-          [ div' [ link' defaultConfig ("/" <> show uID <> "/book/fp-programming") [ text "Functional Programming" ] ]
-          , div' [ link' defaultConfig ("/" <> show uID <> "/book/grothendieck-galois-theory") [ text "Grothendick Galois Theory" ] ]
-          , div' [ link' defaultConfig ("/" <> show uID <> "/book/category-theory") [ text "Category Theory for the Working Mathematician" ]]
+          [ div' [ link' defaultConfig (URL $ "/" <> show uID <> "/book/fp-programming") [ text "Functional Programming" ] ]
+          , div' [ link' defaultConfig (URL $ "/" <> show uID <> "/book/grothendieck-galois-theory") [ text "Grothendick Galois Theory" ] ]
+          , div' [ link' defaultConfig (URL $ "/" <> show uID <> "/book/category-theory") [ text "Category Theory for the Working Mathematician" ]]
           ]
         , div' chrn
         ]

package.json

@@ -24,7 +24,6 @@
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
     "build": "pulp build",
-    "pretest": "pulp browserify --main 'Test.Main' -I test --to karma/index.js",
     "test": "pulp test",
     "example": "node utils/serve-example.js & pulp -w browserify --main 'Example.Main' -I example --to dist/index.js"
   },

src/React/Router/Components.purs

@@ -1,11 +1,11 @@
 module React.Router.Components
   ( browserRouter
   , browserRouterClass
+  , LinkProps(LinkProps)
   , linkSpec
   , link
   , link'
-  , to
-  , goTo
+  , goto
   ) where
 
 
@@ -25,11 +25,11 @@ import DOM.HTML.Types (HISTORY, windowToEventTarget)
 import DOM.HTML.Window (history, location)
 import Data.Foreign (toForeign)
 import Data.List (List)
-import Data.Maybe (Maybe(..), fromMaybe, isNothing, maybe')
+import Data.Maybe (Maybe(..), fromMaybe, isNothing, maybe, maybe')
 import Data.Newtype (un)
 import Data.Tuple (Tuple)
 import Prelude (Unit, bind, const, discard, pure, show, unit, void, ($), (<<<), (<>), (>>=), (||))
-import React (ReactClass, ReactElement, ReactSpec, createClass, createElement, getChildren, getProps, preventDefault, readState, spec, spec', transformState)
+import React (ReactClass, ReactElement, ReactProps, ReactRefs, ReactSpec, ReactState, ReadOnly, ReadWrite, createClass, createElement, getChildren, getProps, preventDefault, readState, spec, spec', transformState)
 import React.DOM (a, div')
 import React.DOM.Props (Props, href, onClick)
 import React.Router.Class (class RoutePropsClass)
@@ -40,7 +40,7 @@ import React.Router.Utils (hasBaseName, joinUrls, stripBaseName, warning)
 -- | RouterState type
 type RouterState =
   { hash :: String
-  , pathname :: String
+  , pathname :: URL
   , search :: String
   }
 
@@ -53,23 +53,23 @@ type RouterProps props arg notFoundProps =
     }
   }
 
-foreign import createPopStateEvent :: String -> Event
+foreign import createPopStateEvent :: URL -> Event
 
 getLocation
   :: forall e
    . RouterConfig
-  -> Eff (dom :: DOM, console :: CONSOLE | e) { hash :: String, pathname :: String, search :: String }
+  -> Eff (dom :: DOM, console :: CONSOLE | e) { hash :: String, pathname :: URL, search :: String }
 getLocation cfg = do
   l <- window >>= location
   h <- hash l
   p <- pathname l
   s <- search l
   let cfgR = un RouterConfig cfg
   warning
-    (isNothing cfgR.baseName || (hasBaseName cfgR.baseName p))
+    (isNothing cfgR.baseName || (hasBaseName cfgR.baseName (URL p)))
     ("""You are using baseName on a page which URL path does not begin with.  Expecting path: """
-     <> p <> """ to begin with: """ <> (fromMaybe "" cfgR.baseName))
-  pure { hash: h, pathname: stripBaseName cfgR.baseName p, search: s }
+     <> p <> """ to begin with: """ <> (maybe "" (un URL) cfgR.baseName))
+  pure { hash: h, pathname: stripBaseName cfgR.baseName (URL p), search: s }
 
 
 -- | `ReactSpec` for the `browserRouterClass` - the main entry point react
@@ -90,7 +90,7 @@ browserRouter cfg = (spec' initialState render) { displayName = "BrowserRouter",
     render this = do
       props <- getProps this
       state <- readState this
-      let loc = state.pathname <> state.search <> state.hash
+      let loc = un URL state.pathname <> state.search <> state.hash
 
       case runRouter loc props.router of
         Nothing -> do
@@ -121,57 +121,60 @@ browserRouterClass
   -> ReactClass (RouterProps props arg notfound)
 browserRouterClass cfg = createClass (browserRouter cfg)
 
-type LinkProps = {to :: String, props :: Array Props}
-
-to :: String -> LinkProps
-to = { to: _, props: [] }
+newtype LinkProps eff = LinkProps
+  { url :: URL
+  , props :: Array Props
+  , action :: Eff (props :: ReactProps, refs :: ReactRefs ReadOnly, state :: ReactState ReadWrite | eff) Unit
+  }
 
 -- | `ReactSpec` for the `link` element; it takes a record of type `LinkProps`
 -- | as properties.  The `props` record property is directly passed to underlying
 -- | `a` element, e.g. this can be used to add css classes.
-linkSpec :: RouterConfig -> ReactSpec LinkProps Unit ()
-linkSpec cfg = (spec unit render) { displayName = "Link" }
+linkSpec :: forall eff. ReactSpec (LinkProps eff) Unit ()
+linkSpec = (spec unit render) { displayName = "Link" }
   where
     render this = do
-      p <- getProps this
+      LinkProps p <- getProps this
       chrn <- getChildren this
       pure $ a
-        ([href p.to, (onClick $ clickHandler this)] <> p.props)
+        ([href (un URL p.url), (onClick $ clickHandler this)] <> p.props)
         chrn
 
     clickHandler this ev = do
       _ <- preventDefault ev
-      { to: url } <-  getProps this
-      goTo cfg url
+      LinkProps { action } <- getProps this
+      action
 
 -- | React class for the `link` element.
-linkClass :: RouterConfig -> ReactClass LinkProps
-linkClass = createClass <<< linkSpec
+linkClass :: forall eff. ReactClass (LinkProps eff)
+linkClass = createClass linkSpec
 
--- | `link` element; use it instead of `a` to route the user through application.
-link :: RouterConfig -> LinkProps -> Array ReactElement -> ReactElement
-link cfg = createElement (linkClass cfg)
+-- | `link` element; use it instead of `a` to route the user through
+-- | application with the default action `goto cfg url` and custom properties.
+link :: RouterConfig -> URL -> Array Props -> Array ReactElement -> ReactElement
+link cfg url props = createElement linkClass (LinkProps { url, props, action: goto cfg url})
 
--- | as `link`, but with empty properties passed to the underlying `a` element.
-link' :: RouterConfig -> String -> Array ReactElement -> ReactElement
-link' cfg = link cfg <<< {to: _, props: []}
+-- | as `link`, but with empty props.
+link' :: RouterConfig -> URL -> Array ReactElement -> ReactElement
+link' cfg url = link cfg url []
 
-goTo
+-- | goto url
+goto
   :: forall eff
    . RouterConfig
-  -> String
+  -> URL
   -> Eff ( console :: CONSOLE
          , dom :: DOM
          , history :: HISTORY
          | eff
          ) Unit
-goTo cfg url = catchException
+goto cfg url = catchException
   (error <<< show)
   (do
     w <- window
     h <- history w
-    let url_ = joinUrls (fromMaybe "" (un RouterConfig cfg).baseName) url
-    pushState (toForeign unit) (DocumentTitle url_) (URL url_) h
+    let url_ = joinUrls (fromMaybe (URL "") (un RouterConfig cfg).baseName) url
+    pushState (toForeign unit) (DocumentTitle (un URL url_)) url_ h
     void $ coerceEff $ dispatchEvent (createPopStateEvent url) (windowToEventTarget w))
   where
     coerceEff :: forall e a. Eff (err :: EXCEPTION | e) a -> Eff (exception :: EXCEPTION | e) a

src/React/Router/Types.purs

@@ -15,6 +15,7 @@ module React.Router.Types
 import Prelude
 
 import Control.Comonad.Cofree ((:<), Cofree)
+import DOM.HTML.History (URL)
 import Data.Lens (Lens', lens)
 import Data.List (List)
 import Data.Map (Map)
@@ -111,7 +112,7 @@ withoutIndex r rs = Tuple r Nothing :< rs
 -- | `:+` lets define routes without index route
 infixr 5 withoutIndex as :+
 
-newtype RouterConfig = RouterConfig { baseName :: Maybe String }
+newtype RouterConfig = RouterConfig { baseName :: Maybe URL }
 
 derive instance newtypeRouterConfig :: Newtype RouterConfig _
 

src/React/Router/Utils.purs

@@ -19,6 +19,7 @@ import Prelude
 import Control.Comonad.Cofree (Cofree, head, tail)
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Console (CONSOLE)
+import DOM.HTML.History (URL(..))
 import Data.Foldable (class Foldable, foldMap, foldl, foldr)
 import Data.List (List(..), concatMap, (:))
 import Data.List as L
@@ -40,36 +41,36 @@ routeToString url = L.intercalate "/" $ unwrap <$> url
 
 foreign import warning :: forall e. Boolean -> String -> Eff (console :: CONSOLE | e) Unit
 
-hasBaseName :: Maybe String -> String -> Boolean
+hasBaseName :: Maybe URL -> URL -> Boolean
 hasBaseName Nothing _ = true
-hasBaseName (Just b) s = isJust (S.stripPrefix (S.Pattern b) s) && (S.null rest || next == "/" || next == "#" || next == "?")
+hasBaseName (Just (URL b)) (URL s) = isJust (S.stripPrefix (S.Pattern b) s) && (S.null rest || next == "/" || next == "#" || next == "?")
   where
     rest = S.drop (S.length b) s
     next = S.take 1 rest
 
-stripBaseName :: Maybe String -> String -> String
+stripBaseName :: Maybe URL -> URL -> URL
 stripBaseName Nothing s = s
-stripBaseName (Just b) s = S.drop (S.length b) s
+stripBaseName (Just (URL b)) (URL s) = URL $ S.drop (S.length b) s
 
 -- | Join two url strings putting `/` separator in between if necessary.
-joinUrls :: String -> String -> String
-joinUrls a b | S.null a = b
-             | S.null b = a
+joinUrls :: URL -> URL -> URL
+joinUrls (URL a) (URL b) | S.null a = URL b
+             | S.null b = URL a
              | otherwise =
   let _a = if S.charAt (S.length a - 1) a == Just '/'
             then S.take (S.length a - 1) a
             else a
       _b = if S.charAt 0 b == Just '/'
             then S.drop 1 b
             else b
-  in _a <> "/" <> _b
+  in URL $ _a <> "/" <> _b
 
 -- | Fold over list of locations and join them as urls.
 -- | ``` purescript
 -- | showLocation (Home : User 1 : Settings) -- /user/1/settings
 -- | ```
-showLocation :: forall a t. Show a => Foldable t => t a -> String
-showLocation t = foldl (\url -> joinUrls url <<< show) "" t
+showLocation :: forall a t. Show a => Foldable t => t a -> URL
+showLocation t = foldl (\url -> joinUrls url <<< URL <<< show) (URL "") t
 
 -- | Find location inside a tail of `Cofree List`.  This is useful for
 -- | querying about children that are mounted under a given component.

test/Utils.purs

@@ -4,9 +4,11 @@ module Test.Utils
 import Prelude
 
 import Control.Comonad.Cofree ((:<))
+import DOM.HTML.History (URL(..))
 import Data.Either (Either(..))
 import Data.List (List(..), (:))
 import Data.Maybe (Maybe(Just, Nothing))
+import Data.Newtype (un)
 import Data.Tuple (Tuple(..))
 import React.Router.Utils (findLocation, hasBaseName, joinUrls, showLocation, stripBaseName, (:<<<), (:>>>))
 import Test.Unit (TestSuite, failure, suite, test)
@@ -23,38 +25,38 @@ testSuite :: forall eff. TestSuite eff
 testSuite = suite "Utils" do
 
   test "hasBaseName" do
-    assert "should return true when basename is Nothing" $ hasBaseName Nothing "/home"
-    assert "expected /prefix to have basename (Just /prefix)" $ hasBaseName (Just "/prefix") "/prefix"
-    assert "expected /prefix/ to have basename (Just /prefix)" $ hasBaseName (Just "/prefix") "/prefix/"
-    assert "expected /prefix? to have basename (Just /prefix)" $ hasBaseName (Just "/prefix") "/prefix?"
-    assert "expected /prefix# to have basename (Just /prefix)" $ hasBaseName (Just "/prefix") "/prefix#"
-    assert "expected /prefixx to not have basename (Just /prefix)" $ not $ hasBaseName (Just "/prefix") "/prefixx"
-    assert "expected /home to not have basename (Just /prefix)" $ not $ hasBaseName (Just "/prefix") "/home"
+    assert "should return true when basename is Nothing" $ hasBaseName Nothing $ URL "/home"
+    assert "expected /prefix to have basename (Just /prefix)" $ hasBaseName (Just $ URL "/prefix") $ URL "/prefix"
+    assert "expected /prefix/ to have basename (Just /prefix)" $ hasBaseName (Just $ URL "/prefix") $ URL "/prefix/"
+    assert "expected /prefix? to have basename (Just /prefix)" $ hasBaseName (Just $ URL "/prefix") $ URL "/prefix?"
+    assert "expected /prefix# to have basename (Just /prefix)" $ hasBaseName (Just $ URL "/prefix") $ URL "/prefix#"
+    assert "expected /prefixx to not have basename (Just /prefix)" $ not $ hasBaseName (Just $ URL "/prefix") $ URL "/prefixx"
+    assert "expected /home to not have basename (Just /prefix)" $ not $ hasBaseName (Just $ URL "/prefix") $ URL "/home"
 
   test "stripBaseName" do
-    let s = stripBaseName (Just "/home") "/home/url"
-    assert ("expected /home/url to be /url but got: " <> s) $ s == "/url"
+    let s = stripBaseName (Just $ URL "/home") $ URL "/home/url"
+    assert ("expected /home/url to be /url but got: " <> un URL s) $ un URL s == "/url"
 
   test "joinUrls" do
-    let r1 = joinUrls "/a" "/b"
+    let r1 = un URL $ joinUrls (URL "/a") (URL "/b")
     assert ("expected /a/b but got " <> r1) $ r1 == "/a/b"
-    let r2 = joinUrls "/a/" "/b"
+    let r2 = un URL $ joinUrls (URL "/a/") (URL "/b")
     assert ("expected /a/b but got " <> r2) $ r2 == "/a/b"
-    let r3 = joinUrls "/a/" "b" 
+    let r3 = un URL $ joinUrls (URL "/a/") (URL "b")
     assert ("expected /a/b but got " <> r3) $ r3 == "/a/b"
-    let r4 = joinUrls "" "/b"
+    let r4 = un URL $ joinUrls (URL "") (URL "/b")
     assert ("expected /b but got " <> r4) $ r4 == "/b"
-    let r5 = joinUrls "/a" ""
+    let r5 = un URL $ joinUrls (URL "/a") (URL "")
     assert ("expected /a but got " <> r5) $ r5 == "/a"
 
   test "showLocation" do
-    let r1 = showLocation (Home : User 1 : Nil)
+    let r1 = un URL $ showLocation (Home : User 1 : Nil)
         e1 = "/home/user/1"
     assert ("expected " <> e1 <> " but got " <> r1) $ r1 == e1
-    let r2 = showLocation (Home : User 1 : Settings : Nil)
+    let r2 = un URL $ showLocation (Home : User 1 : Settings : Nil)
         e2 = "/home/user/1/settings/"
     assert ("expected " <> e2 <> " but got " <> r2) $ r2 == e2
-    let r3 = showLocation [Home, Settings, User 1]
+    let r3 = un URL $ showLocation [Home, Settings, User 1]
         e3 = "/home/settings/user/1"
     assert ("expected " <> e3 <> " but got " <> r3) $ r3 == e3