├── .editorconfig
├── .github
    └── workflows
    │   └── ci.yml
├── .gitignore
├── .vscode
    └── settings.json
├── README.md
├── bower.json
├── package-lock.json
├── package.json
├── packages.dhall
├── spago.dhall
└── src
    └── Web
        ├── Router.purs
        └── Router
            ├── Hash.purs
            ├── Internal
                ├── Control.purs
                └── Types.purs
            └── PushState.purs


/.editorconfig:
--------------------------------------------------------------------------------
 1 | root = true
 2 | 
 3 | [*]
 4 | indent_style = space
 5 | indent_size = 2
 6 | charset = utf-8
 7 | trim_trailing_whitespace = true
 8 | insert_final_newline = true
 9 | end_of_line = lf
10 | 


--------------------------------------------------------------------------------
/.github/workflows/ci.yml:
--------------------------------------------------------------------------------
 1 | name: CI
 2 | 
 3 | on: push
 4 | 
 5 | jobs:
 6 |   build:
 7 |     runs-on: ubuntu-latest
 8 |     steps:
 9 |       - uses: actions/checkout@v2
10 | 
11 |       - uses: actions/setup-node@v3
12 | 
13 |       - uses: thomashoneyman/setup-purescript@main
14 |         with:
15 |           purescript: "0.15.4"
16 |           spago: "0.20.9"
17 | 
18 |       - name: Cache PureScript dependencies
19 |         uses: actions/cache@v2
20 |         with:
21 |           key: ${{ runner.os }}-spago-${{ hashFiles('**/*.dhall') }}
22 |           path: |
23 |             .spago
24 |             output
25 | 
26 |       - run: npm run -s build
27 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | /bower_components/
 2 | /node_modules/
 3 | /.pulp-cache/
 4 | /output/
 5 | /generated-docs/
 6 | /.psc-package/
 7 | /.psc*
 8 | /.purs*
 9 | /.psa*
10 | /.spago
11 | 


--------------------------------------------------------------------------------
/.vscode/settings.json:
--------------------------------------------------------------------------------
 1 | {
 2 |   "purescript.addNpmPath": true,
 3 |   "purescript.addPscPackageSources": true,
 4 |   "purescript.addSpagoSources": true,
 5 |   "purescript.buildCommand": "spago build -- --json-errors",
 6 |   "purescript.formatter": "purs-tidy",
 7 |   "[purescript]": {
 8 |     "editor.formatOnSave": true
 9 |   }
10 | }
11 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # purescript-web-router
  2 | 
  3 | A router for browsers that supports asynchronous routing logic. Bring your own printing and parsing (check out [routing-duplex](https://github.com/natefaubion/purescript-routing-duplex)).
  4 | 
  5 | For a basic React example see [here](https://github.com/robertdp/purescript-web-router-example/tree/master/src).
  6 | 
  7 | ## How to use
  8 | 
  9 | ### 1. Install with Spago
 10 | 
 11 | `$ spago install web-router`
 12 | 
 13 | ### 2. Define your routes
 14 | 
 15 | ```purescript
 16 | data Route
 17 |   = Page Page
 18 |   | NotFound
 19 | 
 20 | data Page
 21 |   = Home
 22 |   | ProductList
 23 |   | ProductView ProductId
 24 |   | About
 25 |   | ContactUs
 26 | 
 27 | type ProductId = Int
 28 | ```
 29 | 
 30 | ### 3. Implement parsing and printing
 31 | 
 32 | This example uses [routing-duplex](https://github.com/natefaubion/purescript-routing-duplex).
 33 | 
 34 | <details>
 35 | <summary>Imports</summary>
 36 | 
 37 | ```purescript
 38 | import Prelude hiding ((/))
 39 | import Data.Either (Either)
 40 | import Data.Generic.Rep (class Generic)
 41 | import Routing.Duplex (RouteDuplex', default, end, int, parse, print, root, segment)
 42 | import Routing.Duplex.Generic (noArgs, sum)
 43 | import Routing.Duplex.Generic.Syntax ((/))
 44 | import Routing.Duplex.Parser (RouteError)
 45 | ```
 46 | 
 47 | </details>
 48 | 
 49 | ```purescript
 50 | derive instance Generic Route _
 51 | derive instance Generic Page _
 52 | 
 53 | productId :: RouteDuplex' ProductId
 54 | productId = int segment
 55 | 
 56 | routes :: RouteDuplex' Route
 57 | routes =
 58 |   default NotFound $
 59 |     sum
 60 |       { "Page": pages
 61 |       , "NotFound": "404" / noArgs
 62 |       }
 63 | 
 64 | pages :: RouteDuplex' Page
 65 | pages =
 66 |   root $ end $
 67 |     sum
 68 |       { "Home": noArgs
 69 |       , "ProductList": "products" / noArgs
 70 |       , "ProductView": "products" / productId
 71 |       , "About": "about" / noArgs
 72 |       , "ContactUs": "about" / noArgs
 73 |       }
 74 | 
 75 | -- | This is the route parser we need to pass to the driver.
 76 | -- | It can produce any route which allows the parser to return a value of `NotFound` instead of failing.
 77 | parseRoute :: forall  String -> Either RouteError Route
 78 | parseRoute = parse routes
 79 | 
 80 | -- | This is the route printer we need to pass to the driver.
 81 | -- | It can only print paths to valid pages, which means a path can't be produced for the `NotFound` route.
 82 | -- | With this approach routes can be seperated based on whether they should be a navigation target and have a URL.
 83 | -- | Note: assymetry is not required, and a symmetrical printer works as well.
 84 | printRoute :: Page -> String
 85 | printRoute = print pages
 86 | ```
 87 | 
 88 | ### 4. Define how your application reacts to navigation and routing events
 89 | 
 90 | <details>
 91 | <summary>Imports</summary>
 92 | 
 93 | ```purescript
 94 | import Web.Router as Router
 95 | ```
 96 | 
 97 | </details>
 98 | 
 99 | ```purescript
100 | onNavigation :: Maybe Route -> Route -> Router.RouterM Route Page Router.Routing Router.Resolved Unit
101 | onNavigation previousRoute requestedRoute =
102 |   case requestedRoute of
103 |     NotFound ->
104 |       case previousRoute of
105 |         Just (Page page) -> Router.do
106 |           liftEffect showBrokenNavigationMessage
107 |           Router.redirect page -- redirect back to the previous page and show a message
108 |         _ ->
109 |           Router.continue -- no previous page, so just show the "not found" page
110 |     _ -> Router.do
111 |       access <- liftAff fetchUserAccess
112 |       if userHasAccess requestedRoute access then
113 |         Router.continue -- they have access, so resolve with the requested page
114 |       else
115 |         Router.override NotFound -- no access, so pretend the page doesn't exist
116 | 
117 | 
118 | onEvent :: Router.RoutingEvent Route -> Effect Unit
119 | onEvent newEvent =
120 |   case newEvent of
121 |     Router.Routing previousRoute requestedRoute ->
122 |       showNavigationSpinner
123 |     Router.Resolved previousRoute newRoute ->
124 |       hideNavigationSpinner
125 |       setCurrentRoute newRoute
126 | ```
127 | 
128 | ### 5. Connect up the driver and router
129 | 
130 | <details>
131 | <summary>Imports</summary>
132 | 
133 | ```purescript
134 | import Web.Router as Router
135 | import Web.Router.PushState as PushState
136 | ```
137 | 
138 | </details>
139 | 
140 | ```purescript
141 | mkRouter :: Effect (Router.Router Route Page)
142 | mkRouter = do
143 |   driver <- PushState.mkInterface parseRoute printRoute
144 |   router <- Router.mkInterface onNavigation onEvent driver
145 |   pure router
146 | ```
147 | 
148 | Both pushstate and hash drivers are included, or a custom driver can be implemented. An example of a custom driver could be one that synchronises some navigation state over sockets, for an experience where one user's behaviour could be broadcast to multiple users to follow along.
149 | 


--------------------------------------------------------------------------------
/bower.json:
--------------------------------------------------------------------------------
 1 | {
 2 |     "name": "purescript-web-router",
 3 |     "license": [
 4 |         "BSD-3-Clause"
 5 |     ],
 6 |     "repository": {
 7 |         "type": "git",
 8 |         "url": "https://github.com/robertdp/purescript-web-router.git"
 9 |     },
10 |     "ignore": [
11 |         "**/.*",
12 |         "node_modules",
13 |         "bower_components",
14 |         "output"
15 |     ],
16 |     "dependencies": {
17 |         "purescript-aff": "^v7.0.0",
18 |         "purescript-effect": "^v4.0.0",
19 |         "purescript-foldable-traversable": "^v6.0.0",
20 |         "purescript-foreign": "^v7.0.0",
21 |         "purescript-freet": "^v7.0.0",
22 |         "purescript-indexed-monad": "^v2.1.0",
23 |         "purescript-maybe": "^v6.0.0",
24 |         "purescript-prelude": "^v6.0.0",
25 |         "purescript-profunctor-lenses": "^v8.0.0",
26 |         "purescript-refs": "^v6.0.0",
27 |         "purescript-routing": "^v11.0.0",
28 |         "purescript-type-equality": "^v4.0.1"
29 |     }
30 | }
31 | 


--------------------------------------------------------------------------------
/package.json:
--------------------------------------------------------------------------------
 1 | {
 2 |   "name": "purescript-web-router",
 3 |   "version": "1.0.0",
 4 |   "description": "",
 5 |   "main": "index.js",
 6 |   "scripts": {
 7 |     "build": "spago build",
 8 |     "postinstall": "spago install"
 9 |   },
10 |   "author": "",
11 |   "license": "ISC",
12 |   "devDependencies": {
13 |     "bower": "^1.8.14",
14 |     "pulp": "^16.0.2",
15 |     "purescript": "^0.15.4",
16 |     "purescript-psa": "^0.8.2",
17 |     "purs-tidy": "^0.9.0",
18 |     "spago": "^0.20.9"
19 |   }
20 | }
21 | 


--------------------------------------------------------------------------------
/packages.dhall:
--------------------------------------------------------------------------------
1 | let upstream =
2 |       https://github.com/purescript/package-sets/releases/download/psc-0.15.4-20220718/packages.dhall
3 |         sha256:a6d66723b6109f1e3eaf6575910f1c51aa545965ce313024ba329360e2f009ac
4 | 
5 | in  upstream
6 | 


--------------------------------------------------------------------------------
/spago.dhall:
--------------------------------------------------------------------------------
 1 | { name = "web-router"
 2 | , license = "BSD-3-Clause"
 3 | , repository = "https://github.com/robertdp/purescript-web-router.git"
 4 | , dependencies =
 5 |   [ "aff"
 6 |   , "effect"
 7 |   , "foldable-traversable"
 8 |   , "foreign"
 9 |   , "freet"
10 |   , "indexed-monad"
11 |   , "maybe"
12 |   , "prelude"
13 |   , "profunctor-lenses"
14 |   , "refs"
15 |   , "routing"
16 |   , "type-equality"
17 |   ]
18 | , packages = ./packages.dhall
19 | , sources = [ "src/**/*.purs" ]
20 | }
21 | 


--------------------------------------------------------------------------------
/src/Web/Router.purs:
--------------------------------------------------------------------------------
 1 | module Web.Router
 2 |   ( module Control
 3 |   , module Ix
 4 |   , module Types
 5 |   , mkInterface
 6 |   ) where
 7 | 
 8 | import Prelude
 9 | import Control.Monad.Indexed.Qualified (apply, bind, discard, map, pure) as Ix
10 | import Data.Foldable (for_)
11 | import Data.Maybe (Maybe(..))
12 | import Effect (Effect)
13 | import Effect.Aff (Aff, error, killFiber, launchAff, launchAff_)
14 | import Effect.Class (liftEffect)
15 | import Effect.Ref as Ref
16 | import Web.Router.Internal.Control (Resolved, RouterIndex, RouterM, Routing, continue, override, redirect) as Control
17 | import Web.Router.Internal.Control (RouterCommand(..), Resolved, RouterM, Routing, runRouter)
18 | import Web.Router.Internal.Types (DriverInterface, DriverInterface', RouterEvent(..), RouterInterface, _Resolved, _RouterEvent, _Routing, isResolved, isRouting) as Types
19 | import Web.Router.Internal.Types (DriverInterface, RouterEvent(..), RouterInterface)
20 | 
21 | mkInterface
22 |   :: forall i o
23 |    . (Maybe i -> i -> RouterM i o Routing Resolved Unit)
24 |   -> (RouterEvent i -> Effect Unit)
25 |   -> DriverInterface i o
26 |   -> Effect (RouterInterface o)
27 | mkInterface onNavigation onEvent driver = do
28 |   lastFiberRef <- Ref.new Nothing
29 |   lastEventRef <- Ref.new Nothing
30 |   let
31 |     readPreviousRoute :: Effect (Maybe i)
32 |     readPreviousRoute =
33 |       Ref.read lastEventRef <#>
34 |         case _ of
35 |           Just (Resolved _ route) -> Just route
36 |           Just (Routing (Just route) _) -> Just route
37 |           _ -> Nothing
38 | 
39 |     handleEvent :: RouterEvent i -> Effect Unit
40 |     handleEvent event = do
41 |       Ref.write (Just event) lastEventRef
42 |       onEvent event
43 | 
44 |     onCommand :: forall a. i -> RouterCommand i o a -> Aff Unit
45 |     onCommand newRoute cmd =
46 |       liftEffect do
47 |         previousRoute <- readPreviousRoute
48 |         case cmd of
49 |           Continue -> handleEvent $ Resolved previousRoute newRoute
50 |           Override route -> handleEvent $ Resolved previousRoute route
51 |           Redirect route -> driver.redirect route
52 | 
53 |     runRouter' :: i -> Effect Unit
54 |     runRouter' newRoute = do
55 |       lastFiber <- Ref.read lastFiberRef
56 |       for_ lastFiber $ killFiber (error "Killing previous routing fiber") >>> launchAff_
57 |       previousRoute <- readPreviousRoute
58 |       handleEvent $ Routing previousRoute newRoute
59 |       newFiber <-
60 |         onNavigation previousRoute newRoute
61 |           # runRouter (onCommand newRoute)
62 |           # launchAff
63 |       Ref.write (Just newFiber) lastFiberRef
64 |   pure
65 |     { initialize: driver.initialize runRouter'
66 |     , navigate: driver.navigate
67 |     , redirect: driver.redirect
68 |     }
69 | 


--------------------------------------------------------------------------------
/src/Web/Router/Hash.purs:
--------------------------------------------------------------------------------
 1 | module Web.Router.Hash where
 2 | 
 3 | import Prelude
 4 | import Data.Foldable (class Foldable)
 5 | import Routing.Hash as Hash
 6 | import Web.Router.Internal.Types (DriverInterface)
 7 | 
 8 | mkInterface :: forall f i o. Foldable f => (String -> f i) -> (o -> String) -> DriverInterface i o
 9 | mkInterface parser printer =
10 |   { initialize: Hash.matchesWith parser <<< const
11 |   , navigate: Hash.setHash <<< printer
12 |   , redirect: Hash.setHash <<< printer
13 |   }
14 | 


--------------------------------------------------------------------------------
/src/Web/Router/Internal/Control.purs:
--------------------------------------------------------------------------------
 1 | module Web.Router.Internal.Control where
 2 | 
 3 | import Prelude
 4 | 
 5 | import Control.Applicative.Indexed (class IxApplicative, iapply, imap, ipure)
 6 | import Control.Apply.Indexed (class IxApply)
 7 | import Control.Bind.Indexed (class IxBind, ibind)
 8 | import Control.Monad.Free.Trans (FreeT, liftFreeT, runFreeT)
 9 | import Control.Monad.Indexed (class IxMonad, iap)
10 | import Data.Functor.Indexed (class IxFunctor)
11 | import Effect.Aff (Aff)
12 | import Effect.Aff.Class (class MonadAff, liftAff)
13 | import Effect.Class (class MonadEffect, liftEffect)
14 | import Type.Equality (class TypeEquals)
15 | 
16 | data RouterCommand :: Type -> Type -> Type -> Type
17 | data RouterCommand i o a
18 |   = Continue
19 |   | Override i
20 |   | Redirect o
21 | 
22 | derive instance Functor (RouterCommand i o)
23 | 
24 | data RouterIndex
25 | 
26 | foreign import data Routing :: RouterIndex
27 | foreign import data Resolved :: RouterIndex
28 | 
29 | newtype RouterM :: Type -> Type -> RouterIndex -> RouterIndex -> Type -> Type
30 | newtype RouterM i o x y a = RouterM (FreeT (RouterCommand i o) Aff a)
31 | 
32 | instance IxFunctor (RouterM i o) where
33 |   imap f (RouterM r) = RouterM (map f r)
34 | 
35 | instance IxApply (RouterM i o) where
36 |   iapply = iap
37 | 
38 | instance IxApplicative (RouterM i o) where
39 |   ipure a = RouterM (pure a)
40 | 
41 | instance IxBind (RouterM i o) where
42 |   ibind (RouterM r) f = RouterM (r >>= \a -> case f a of RouterM r' -> r')
43 | 
44 | instance IxMonad (RouterM i o)
45 | 
46 | instance TypeEquals Routing x => Functor (RouterM i o x x) where
47 |   map = imap
48 | 
49 | instance TypeEquals Routing x => Apply (RouterM i o x x) where
50 |   apply = iapply
51 | 
52 | instance TypeEquals Routing x => Applicative (RouterM i o x x) where
53 |   pure = ipure
54 | 
55 | instance TypeEquals Routing x => Bind (RouterM i o x x) where
56 |   bind = ibind
57 | 
58 | instance TypeEquals Routing x => Monad (RouterM i o x x)
59 | 
60 | instance TypeEquals Routing x => MonadEffect (RouterM i o x x) where
61 |   liftEffect eff = RouterM (liftEffect eff)
62 | 
63 | instance TypeEquals Routing x => MonadAff (RouterM i o x x) where
64 |   liftAff aff = RouterM (liftAff aff)
65 | 
66 | runRouter :: forall i o. (forall a. RouterCommand i o a -> Aff Unit) -> RouterM i o Routing Resolved Unit -> Aff Unit
67 | runRouter handleCmd (RouterM router) = runFreeT (\cmd -> handleCmd cmd *> mempty) router
68 | 
69 | continue :: forall i o. RouterM i o Routing Resolved Unit
70 | continue = RouterM (liftFreeT Continue)
71 | 
72 | override :: forall i o. i -> RouterM i o Routing Resolved Unit
73 | override route = RouterM (liftFreeT (Override route))
74 | 
75 | redirect :: forall i o. o -> RouterM i o Routing Resolved Unit
76 | redirect route = RouterM (liftFreeT (Redirect route))
77 | 


--------------------------------------------------------------------------------
/src/Web/Router/Internal/Types.purs:
--------------------------------------------------------------------------------
 1 | module Web.Router.Internal.Types where
 2 | 
 3 | import Prelude
 4 | import Data.Lens (Lens', Prism', is, lens, prism')
 5 | import Data.Maybe (Maybe(..))
 6 | import Effect (Effect)
 7 | 
 8 | type RouterInterface route =
 9 |   { initialize :: Effect (Effect Unit)
10 |   , navigate :: route -> Effect Unit
11 |   , redirect :: route -> Effect Unit
12 |   }
13 | 
14 | type DriverInterface i o =
15 |   { initialize :: (i -> Effect Unit) -> Effect (Effect Unit)
16 |   , navigate :: o -> Effect Unit
17 |   , redirect :: o -> Effect Unit
18 |   }
19 | 
20 | type DriverInterface' route = DriverInterface route route
21 | 
22 | data RouterEvent route
23 |   = Routing (Maybe route) route
24 |   | Resolved (Maybe route) route
25 | 
26 | derive instance Eq route => Eq (RouterEvent route)
27 | 
28 | _RouterEvent :: forall route. Lens' (RouterEvent route) route
29 | _RouterEvent = lens getter setter
30 |   where
31 |   getter = case _ of
32 |     Routing _ route -> route
33 |     Resolved _ route -> route
34 | 
35 |   setter = case _ of
36 |     Routing route _ -> Routing route
37 |     Resolved route _ -> Resolved route
38 | 
39 | _Routing :: forall route. Prism' (RouterEvent route) route
40 | _Routing =
41 |   prism' (Routing Nothing) case _ of
42 |     Routing _ route -> Just route
43 |     _ -> Nothing
44 | 
45 | _Resolved :: forall route. Prism' (RouterEvent route) route
46 | _Resolved =
47 |   prism' (Resolved Nothing) case _ of
48 |     Resolved _ route -> Just route
49 |     _ -> Nothing
50 | 
51 | isRouting :: forall route. RouterEvent route -> Boolean
52 | isRouting = is _Routing
53 | 
54 | isResolved :: forall route. RouterEvent route -> Boolean
55 | isResolved = is _Resolved
56 | 


--------------------------------------------------------------------------------
/src/Web/Router/PushState.purs:
--------------------------------------------------------------------------------
 1 | module Web.Router.PushState where
 2 | 
 3 | import Prelude
 4 | import Data.Foldable (class Foldable)
 5 | import Effect (Effect)
 6 | import Foreign (unsafeToForeign)
 7 | import Routing.PushState (PushStateInterface)
 8 | import Routing.PushState as PushState
 9 | import Web.Router.Internal.Types (DriverInterface)
10 | 
11 | mkInterface :: forall f i o. Foldable f => (String -> f i) -> (o -> String) -> Effect (DriverInterface i o)
12 | mkInterface parser printer = mkInterface_ parser printer <$> PushState.makeInterface
13 | 
14 | mkInterface_ :: forall f i o. Foldable f => (String -> f i) -> (o -> String) -> PushStateInterface -> DriverInterface i o
15 | mkInterface_ parser printer interface =
16 |   { initialize: \k -> PushState.matchesWith parser (\_ -> k) interface
17 |   , navigate: interface.pushState (unsafeToForeign {}) <<< printer
18 |   , redirect: interface.replaceState (unsafeToForeign {}) <<< printer
19 |   }
20 | 


--------------------------------------------------------------------------------