Merge pull request #50 from natefaubion/remove-ffi

API Updates (breaking)

Author: cryogenian

.gitignore

@@ -5,3 +5,4 @@
 /node_modules/
 /output/
 /public/test.js
+/test/dist

bower.json

@@ -38,7 +38,8 @@
     "purescript-aff": "^4.0.0",
     "purescript-control": "^3.0.0",
     "purescript-console": "^3.0.0",
-    "purescript-integers": "^3.0.0"
+    "purescript-integers": "^3.0.0",
+    "purescript-foldable-traversable": "^3.7.1"
   },
   "devDependencies": {
     "purescript-console": "^3.0.0",

package.json

@@ -3,7 +3,8 @@
   "scripts": {
     "clean": "rimraf output && rimraf .pulp-cache",
     "build": "pulp build -- --censor-lib --strict",
-    "test": "pulp test"
+    "test": "pulp test",
+    "test:browser": "pulp build -I test -m Test.Browser --to test/dist/bundle.js"
   },
   "devDependencies": {
     "pulp": "^11.0.0",

src/Routing.js

@@ -1,67 +1,28 @@
-module Routing (
-  hashChanged,
-  hashes,
-  matches,
-  matches',
-  match,
-  matchWith,
-  matchesAff,
-  matchesAff'
+module Routing
+  ( RoutingEffects
+  , match
+  , matchWith
   ) where
 
-import Control.Monad.Aff (Aff, makeAff, nonCanceler)
-import Control.Monad.Eff (Eff)
-import Data.Either (Either(..), either)
-import Data.Maybe (Maybe(..))
-import Data.String.Regex as R
-import Data.String.Regex.Flags as RF
-import Data.Tuple (Tuple(..))
-import Prelude (Unit, const, pure, unit, ($), (<$))
+import Prelude
+
+import Control.Monad.Eff.Ref (REF)
+import Data.Either (Either)
+import DOM (DOM)
+import Global (decodeURIComponent)
 import Routing.Match (Match, runMatch)
 import Routing.Parser (parse)
 
+type RoutingEffects eff =
+  ( dom :: DOM
+  , ref :: REF
+  | eff
+  )
 
-foreign import decodeURIComponent :: String -> String
-
-foreign import hashChanged :: forall e. (String -> String -> Eff e Unit) -> Eff e Unit
-
-
-hashes :: forall e. (String -> String -> Eff e Unit) -> Eff e Unit
-hashes cb =
-  hashChanged $ \old new -> do
-    cb (dropHash old) (dropHash new)
-  where dropHash h =
-          case R.regex "^[^#]*#" RF.noFlags of
-            Right regX -> R.replace regX "" h
-            Left _     -> h
-
-
--- | Stream of hash changed, callback called when new hash can be matched
--- | First argument of callback is `Just a` when old hash can be matched
--- | and `Nothing` when it can't.
-matches :: forall e a. Match a -> (Maybe a -> a -> Eff e Unit) -> Eff e Unit
-matches = matches' decodeURIComponent
-
-matches' :: forall e a. (String -> String) ->
-            Match a -> (Maybe a -> a -> Eff e Unit) -> Eff e Unit
-matches' decoder routing cb = hashes $ \old new ->
-  let mr = matchWith decoder routing
-      fst = either (const Nothing) Just $ mr old
-  in either (const $ pure unit) (cb fst) $ mr new
-
-matchesAff' :: forall e a. (String -> String) ->
-               Match a -> Aff e (Tuple (Maybe a) a)
-matchesAff' decoder routing =
-  makeAff \k -> nonCanceler <$
-    matches' decoder routing \old new ->
-      k $ Right $ Tuple old new
-
-matchesAff :: forall e a. Match a -> Aff e (Tuple (Maybe a) a)
-matchesAff = matchesAff' decodeURIComponent
-
-
+-- | Runs a `Match` parser.
 match :: forall a. Match a -> String -> Either String a
 match = matchWith decodeURIComponent
 
+-- | Runs a `Match` parser given a custom String decoder.
 matchWith :: forall a. (String -> String) -> Match a -> String -> Either String a
-matchWith decoder matcher hash = runMatch matcher $ parse decoder hash
+matchWith decoder matcher = runMatch matcher <<< parse decoder

src/Routing.purs

@@ -1,12 +1,91 @@
-module Routing.Hash where
+module Routing.Hash
+  ( getHash
+  , setHash
+  , modifyHash
+  , foldHashes
+  , hashes
+  , matches
+  , matchesWith
+  , module Routing
+  ) where
 
-import Prelude (Unit, (>>=), (<$>))
-import Control.Monad.Eff (Eff())
-import DOM (DOM())
+import Prelude
 
-foreign import setHash :: forall e. String -> Eff (dom :: DOM |e) Unit
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Ref (newRef, readRef, writeRef)
+import DOM (DOM)
+import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
+import DOM.HTML (window)
+import DOM.HTML.Event.EventTypes (hashchange)
+import DOM.HTML.Location as L
+import DOM.HTML.Types (windowToEventTarget)
+import DOM.HTML.Window (location)
+import Data.Foldable (class Foldable, indexl)
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.String (Pattern(..), stripPrefix)
+import Routing (RoutingEffects, match, matchWith)
+import Routing.Match (Match)
 
-foreign import getHash :: forall e. Eff (dom :: DOM |e) String
+-- | Gets the global location hash.
+getHash :: forall eff. Eff (dom :: DOM | eff) String
+getHash = window >>= location >>= L.hash >>> map (stripPrefix (Pattern "#") >>> fromMaybe "")
 
-modifyHash :: forall e. (String -> String) -> Eff (dom :: DOM|e) Unit
+-- | Sets the global location hash.
+setHash :: forall eff. String -> Eff (dom :: DOM | eff) Unit
+setHash h = window >>= location >>= L.setHash h
+
+-- | Modifies the global location hash.
+modifyHash :: forall eff. (String -> String) -> Eff (dom :: DOM | eff) Unit
 modifyHash fn = (fn <$> getHash) >>= setHash
+
+-- | Folds effectfully over hash changes given a callback and an initial hash.
+-- | The provided String is the hash portion of the `Location` with the '#'
+-- | prefix stripped. Returns an effect which will remove the listener.
+foldHashes
+  :: forall eff a
+   . (a -> String -> Eff (RoutingEffects eff) a)
+  -> (String -> Eff (RoutingEffects eff) a)
+  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
+foldHashes cb init = do
+  ref <- newRef =<< init =<< getHash
+  win <- windowToEventTarget <$> window
+  let listener = eventListener \_ -> writeRef ref =<< join (cb <$> readRef ref <*> getHash)
+  addEventListener hashchange listener false win
+  pure $ removeEventListener hashchange listener false win
+
+-- | Runs the callback on every hash change providing the previous hash and the
+-- | latest hash. The provided String is the hash portion of the `Location` with
+-- | the '#' prefix stripped. Returns an effect which will remove the listener.
+hashes
+  :: forall eff
+   . (Maybe String -> String -> Eff (RoutingEffects eff) Unit)
+  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
+hashes = matchesWith Just
+
+-- | Runs the callback on every hash change using a given `Match` parser to
+-- | extract a route from the hash. If a hash fails to parse, it is ignored.
+-- | To avoid dropping hashes, provide a fallback alternative in your parser.
+-- | Returns an effect which will remove the listener.
+matches
+  :: forall eff a
+   . Match a
+  -> (Maybe a -> a -> Eff (RoutingEffects eff) Unit)
+  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
+matches = matchesWith <<< match
+
+-- | Runs the callback on every hash change using a given custom parser to
+-- | extract a route from the hash. If a hash fails to parse, it is ignored.
+-- | To avoid dropping hashes, provide a fallback alternative in your parser.
+-- | Returns an effect which will remove the listener.
+matchesWith
+  :: forall eff f a
+   . Foldable f
+  => (String -> f a)
+  -> (Maybe a -> a -> Eff (RoutingEffects eff) Unit)
+  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
+matchesWith parser cb = foldHashes go (go Nothing)
+  where
+  go a =
+    maybe (pure a) (\b -> Just b <$ cb a b)
+      <<< indexl 0
+      <<< parser

src/Routing/Hash.js

@@ -0,0 +1,98 @@
+module Test.Browser where
+
+import Prelude
+
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Exception (EXCEPTION, error, throwException)
+import DOM.Event.EventTarget (addEventListener, eventListener)
+import DOM.HTML (window)
+import DOM.HTML.Document (body)
+import DOM.HTML.Event.EventTypes (load)
+import DOM.HTML.Types (htmlDocumentToDocument, htmlElementToNode, windowToEventTarget)
+import DOM.HTML.Window (document)
+import DOM.Node.Document (createElement, createTextNode)
+import DOM.Node.Element (setAttribute)
+import DOM.Node.Node (appendChild)
+import DOM.Node.Types (Document, Node, elementToNode, textToNode)
+import Data.Foldable (oneOf)
+import Data.Maybe (Maybe(..), maybe)
+import Routing.Hash (RoutingEffects, hashes, setHash)
+import Routing.Match (Match)
+import Routing.Match.Class (lit)
+
+type Effects = RoutingEffects (exception :: EXCEPTION)
+
+data Route = A | B | U
+
+route :: Match Route
+route = oneOf
+  [ lit "a" $> A
+  , lit "b" $> B
+  , pure U
+  ]
+
+runTests :: Eff Effects Unit
+runTests = do
+  doc  <- window >>= document
+  body <- body doc >>= maybe (throwException (error "Body not found")) pure
+
+  let
+    doc' :: Document
+    doc' = htmlDocumentToDocument doc
+
+    renderSuccess :: String -> Eff Effects Node
+    renderSuccess testName = do
+      row <- createElement "div" doc'
+      setAttribute "class" "success" row
+      tag <- createElement "b" doc'
+      ok <- createTextNode "[OK]" doc'
+      name <- createTextNode testName doc'
+      _ <- appendChild (elementToNode tag) (elementToNode row)
+      _ <- appendChild (textToNode name) (elementToNode row)
+      _ <- appendChild (textToNode ok) (elementToNode tag)
+      pure (elementToNode row)
+
+    renderError :: String -> String -> Eff Effects Node
+    renderError testName err = do
+      row <- createElement "div" doc'
+      setAttribute "class" "error" row
+      tag <- createElement "b" doc'
+      ok <- createTextNode "[FAIL]" doc'
+      name <- createTextNode testName doc'
+      error <- createElement "div" doc'
+      setAttribute "class" "error-text" error
+      errText <- createTextNode err doc'
+      _ <- appendChild (textToNode ok) (elementToNode tag)
+      _ <- appendChild (elementToNode tag) (elementToNode row)
+      _ <- appendChild (textToNode name) (elementToNode row)
+      _ <- appendChild (textToNode errText) (elementToNode error)
+      _ <- appendChild (elementToNode error) (elementToNode row)
+      pure (elementToNode row)
+
+    assertEq :: forall a. Show a => Eq a => String -> a -> a -> Eff Effects Unit
+    assertEq testName a b = do
+      if a == b
+        then do
+          void $ flip appendChild (htmlElementToNode body) =<< renderSuccess testName
+        else do
+          let err = show a <> " /= " <> show b
+          _ <- flip appendChild (htmlElementToNode body) =<< renderError testName err
+          throwException (error $ testName <> ": " <> err)
+
+    assert :: String -> Boolean -> Eff Effects Unit
+    assert testName = assertEq testName true
+
+  _ <- hashes case _, _ of
+    Nothing, ""   -> assert "Hashes: Initial value" true
+    Just "", "a"  -> assert "Hashes: ? -> a" true *> setHash "b"
+    Just "a", "b" -> assert "Hashes: a -> b" true *> setHash ""
+    Just "b", ""  -> assert "Hashes: b -> ?" true
+    _, _          -> assert "Hashes: fail" false
+
+  setHash "a"
+
+main :: Eff Effects Unit
+main =
+  window
+    >>= windowToEventTarget
+    >>> addEventListener load (eventListener (const runTests)) false

src/Routing/Hash.purs

@@ -0,0 +1,20 @@
+<!doctype html>
+<title>Routing tests</title>
+<style>
+  body {
+    font-family: sans-serif;
+  }
+  body > div {
+    margin-bottom: 10px;
+  }
+  b {
+    margin-right: 10px;
+  }
+  .success b {
+    color: green;
+  }
+  .error b {
+    color: red;
+  }
+</style>
+<script src="dist/bundle.js"></script>