Add codecs for polymorphic variants

README.md

@@ -379,6 +379,78 @@ route = root $ sum
   }
 ```
 
+## Example: Using Variant codecs to represent polymorphic CRUD operations
+In the previous example we’ve seen how to compose codecs in CRUD operations, but the route data types for those operations were fixed, closed; and yet, in most cases, resources in an application need to support different CRUD operations or only a subset of those.
+
+In order to solve this problem, we may use the `Variant` data type from `Data.Variant`. This library exports codecs for polymorphic variants: `variant` and `vcase` (and its operator alias `%=`). The API for these combinators follows the idea of `record` and `prop` seen previously.
+
+In this example we’ll model the same `Post` codec from the previous example, supporting _create_, _read_ and _update_ operations, as well as a `User` codec that supports only the _read_ and _update_ operations, with the caveat that the update operation for users should not take an argument, as a user should only be able to update their own data, and not that of others.
+
+So a complete description of the routes for posts is:
+
+* `/` should represent creation
+* `/:id` should represent reading
+* `/edit/:id` should represent updating
+
+And for users:
+
+* `/:id` should represent reading
+* `/edit` should represent updating
+
+Let’s first create some standard type aliases for common CRUD operations that may be used with `Variant` first:
+
+```purescript
+type Create r = (create :: Unit | r)
+type Read a r = (read :: a | r)
+type Update a r = (update :: a | r)
+```
+
+We can use these type aliases to build the parts of the `Route` data type that describe the user and post route schemes. In this example, the `+` type operator from `Type.Row` is used (from the `purescript-typelevel-prelude` package) for extra syntactic sugar:
+
+```purescript
+data Route
+  = ...
+  | User (Variant (Read Username + Update Unit + ()))
+  | Post Username (Variant (Create + Read PostId + Update PostId + ()))
+```
+
+Next, we can create some helper functions for defining codecs for these common operations using `vcase`:
+
+```purescript
+create :: forall r. Lacks "create" r => RouteDuplex' (Variant r) -> RouteDuplex' (Variant (Create r))
+create = vcase (SProxy :: _ "create") (pure unit)
+
+read :: forall a r. Lacks "read" r => RouteDuplex' a -> RouteDuplex' (Variant r) -> RouteDuplex' (Variant (Read a r))
+read = vcase (SProxy :: _ "read")
+
+update :: forall a r. Lacks "update" r => RouteDuplex' a -> RouteDuplex' (Variant r) -> RouteDuplex' (Variant (Update a r))
+update = vcase (SProxy :: _ "update")
+```
+
+And finally, we can use `variant` and the helper codecs we’ve just defined together with `postId` and `uname` to produce the larger `Route` codec:
+
+```purescript
+route = root $ sum
+  { ...
+  , "User":
+      path "user"
+        $ variant
+        # read uname
+        # update (pure unit)
+  , "Post":
+      "user"
+      / uname
+      / path "post"
+          ( variant
+              # create
+              # read postId
+              # update postId
+          )
+  }
+```
+
+It’s important to note here that the read and update routes for users may collide. To solve this ambiguity, we had to define the variant parser for users in the correct order: `update` takes priority over `read` as it is applied later.
+
 ## Example: Running our codec with `purescript-routing`
 
 We've developed a capable parser and printer for our route data type. To be useful, though, we'll want to use our parser along with a library that handles hash-based or pushState routing for us. The most common choice is the `purescript-routing` library. If you aren't familiar with how the library works, [consider skimming the official guide](https://github.com/slamdata/purescript-routing/blob/v8.0.0/GUIDE.md).

bower.json

@@ -17,7 +17,8 @@
     "purescript-globals": "^4.0.0",
     "purescript-strings": "^4.0.0",
     "purescript-lazy": "^4.0.0",
-    "purescript-profunctor": "^4.0.0"
+    "purescript-profunctor": "^4.0.0",
+    "purescript-variant": "^6.0.1"
   },
   "devDependencies": {
     "purescript-psci-support": "^4.0.0",

src/Routing/Duplex.purs

@@ -23,6 +23,9 @@ module Routing.Duplex
   , record
   , prop
   , (:=)
+  , variant
+  , vcase
+  , (%=)
   , params
   , buildParams
   , class RouteDuplexParams
@@ -31,7 +34,7 @@ module Routing.Duplex
 
 import Prelude
 
-import Control.Alt (class Alt)
+import Control.Alt (class Alt, (<|>))
 import Control.Alternative (class Alternative)
 import Data.Either (Either)
 import Data.Foldable (class Foldable, foldMap, foldr)
@@ -40,14 +43,17 @@ import Data.Profunctor (class Profunctor)
 import Data.String (Pattern(..))
 import Data.String as String
 import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
+import Data.Variant (Variant)
+import Data.Variant as Variant
 import Prim.Row as Row
 import Prim.RowList (kind RowList, class RowToList, Cons, Nil)
 import Record as Record
-import Routing.Duplex.Parser (RouteParser)
+import Routing.Duplex.Parser (RouteError(..), RouteParser(..), RouteResult(..))
 import Routing.Duplex.Parser as Parser
 import Routing.Duplex.Printer (RoutePrinter)
 import Routing.Duplex.Printer as Printer
 import Type.Data.RowList (RLProxy(..))
+import Unsafe.Coerce (unsafeCoerce)
 
 -- | The core abstraction of this library. The values of this type can be used both for parsing
 -- | values of type `o` from `String` as well as printing values of type `i` into `String`.
@@ -328,6 +334,44 @@ prop sym (RouteDuplex f g) (RouteDuplex x y) =
 
 infix 2 prop as :=
 
+-- | Combined with `vcase`, builds a Variant where the order of parsing and
+-- | printing matters. As in the example below, the later `vcase`s take priority
+-- | when parsing/printing:
+-- |
+-- | ```purescript
+-- | userRoutes =
+-- |   variant
+-- |     # vcase (SProxy :: _ "list") (pure unit)
+-- |     # vcase (SProxy :: _ "edit") (str segment)
+-- |     # vcase (SProxy :: _ "new") (path "new" $ pure unit)
+-- | ```
+variant :: forall r. RouteDuplex r (Variant ())
+variant = RouteDuplex mempty (Chomp \_ -> Fail EndOfPath)
+
+-- | Parse/print a single case of a variant. Must be used with `variant`.
+vcase :: forall sym a b r1 r1_ r2 r3.
+  IsSymbol sym =>
+  Row.Cons sym a r1_ r1 =>
+  Row.Cons sym b r2 r3 =>
+  Row.Lacks sym r2 =>
+  SProxy sym ->
+  RouteDuplex a b ->
+  RouteDuplex (Variant r1_) (Variant r2) ->
+  RouteDuplex (Variant r1) (Variant r3)
+vcase sym (RouteDuplex enc_a dec_b) (RouteDuplex enc_r1 dec_r2) =
+  RouteDuplex (Variant.on sym enc_a enc_r1) (Variant.inj sym <$> dec_b <|> expand1 sym <$> dec_r2)
+  where
+  -- A variant of `Data.Variant.expand` is used in order to avoid adding a
+  -- redundant `Row.Union` constraint to `vcase`.
+  expand1 :: forall sym' lt x gt.
+    Row.Cons sym' x lt gt =>
+    SProxy sym' ->
+    Variant lt ->
+    Variant gt
+  expand1 _ = unsafeCoerce
+
+infix 2 vcase as %=
+
 class RouteDuplexParams (r1 :: # Type) (r2 :: # Type) | r1 -> r2 where
   -- | Builds a `RouteDuplex` from a record of query parameter parsers/printers, where
   -- | each property corresponds to a query parameter with the same name.

test/Main.purs

@@ -7,8 +7,9 @@ import Data.Generic.Rep (class Generic)
 import Data.Generic.Rep.Show (genericShow)
 import Data.String.Gen (genAlphaString)
 import Data.Symbol (SProxy(..))
+import Data.Variant (Variant)
 import Effect (Effect)
-import Routing.Duplex (RouteDuplex', flag, int, param, parse, print, record, rest, root, segment, string, (:=))
+import Routing.Duplex (RouteDuplex', flag, int, param, parse, prefix, print, record, rest, root, segment, string, variant, (%=), (:=))
 import Routing.Duplex.Generic (noArgs)
 import Routing.Duplex.Generic as RDG
 import Routing.Duplex.Generic.Syntax ((/), (?))
@@ -21,6 +22,7 @@ data TestRoute
   | Foo String Int String { a :: String, b :: Boolean }
   | Bar { id :: String, search :: String }
   | Baz String (Array String)
+  | Qux (Variant (id :: String, search :: String, list :: Unit))
 
 derive instance eqTestRoute :: Eq TestRoute
 derive instance genericTestRoute :: Generic TestRoute _
@@ -41,6 +43,7 @@ genTestRoute = do
 
 _id = SProxy :: SProxy "id"
 _search = SProxy :: SProxy "search"
+_list = SProxy :: SProxy "list"
 
 route :: RouteDuplex' TestRoute
 route =
@@ -49,6 +52,7 @@ route =
     , "Foo": fooRoute
     , "Bar": barRoute
     , "Baz": bazRoute
+    , "Qux": quxRoute
     }
   where
   fooRoute =
@@ -62,6 +66,12 @@ route =
   bazRoute =
     segment / rest
 
+  quxRoute =
+    variant
+      # _list %= pure unit
+      # _id %= segment
+      # _search %= prefix "search" segment
+
 main :: Effect Unit
 main = do
   combinatorUnitTests