rowdy-0.0.1.0: src/Rowdy.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Rowdy is a DSL for defining web routes. The DSL is only a nice syntax for
-- expressing the tree-like structure of routes -- to actually interpret the
-- route into something useful, you'll need another package.
--
-- @rowdy-yesod@ provides a function that converts this representation into the
-- Yesod route format, allowing you to drop the quasiquotater and use a plain
-- Haskell DSL.
--
-- @rowdy-servant@ provides a function that converts the DSL into Servant's type
-- level DSL for defining routes. This allows you to work with a value-level
-- DSL, taking full advantage of Haskell's value level programming, and then
-- promote the DSL to the type level using Template Haskell.
module Rowdy where
import Control.Monad.Writer
import Data.DList (DList (..))
import qualified Data.DList as DList
-- | A 'RouteDsl' is a type useful for constructing web routes. At it's heart,
-- it is a DSL for constructing a 'RouteTree', and is totally optional.
--
-- Routes are defined by how they handle @nest@ing, what sorts of values are
-- used to represent @capture@s, and what values are used to represent
-- endpoints.
--
-- @since 0.0.1.0
newtype RouteDsl nest capture terminal a = RouteDsl
{ unRouteDsl :: Writer (DForest nest capture terminal) a
} deriving
( Functor, Applicative, Monad
, MonadWriter (DForest nest capture terminal)
)
-- | Run the given 'RouteDsl' and convert it into the 'Forest' of routes. If you
-- are defining an interpreter for a web framework, you will want to call this
-- on the 'RouteDsl' value.
--
-- @since 0.0.1.0
runRouteDsl :: RouteDsl n c e a -> Forest n c e
runRouteDsl =
DList.toList . execWriter . unRouteDsl
-- | Run the given 'RouteDsl' and convert it into a 'DList' of routes. This is
-- useful when implementing combinators.
--
-- @since 0.0.1.0
runRouteDsl' :: RouteDsl n c e a -> DForest n c e
runRouteDsl' = execWriter . unRouteDsl
-- | Introduce a @capture@ into all of the routes defined in the second
-- argument. This function does not introduce nesting, so multiple distinct
-- routes will be created.
--
-- As an example:
--
-- @
-- example :: RouteDsl nest String String ()
-- example =
-- 'pathComponent' "hello" $ do
-- 'terminal' "first route"
-- 'terminal' "second route"
-- @
--
-- Calling @'runRouteDsl' example@ will give a data structure like:
--
-- @
-- [ 'PathComponent' "hello" ('Leaf' "first route")
-- , 'PathComponent' "hello" ('Leaf' "second route")
-- ]
-- @
--
-- @since 0.0.1.0
pathComponent
:: capture
-> RouteDsl nest capture endpoint ()
-> RouteDsl nest capture endpoint ()
pathComponent pp =
tell . fmap (PathComponent pp) . runRouteDsl'
-- | An infix operator for 'pathComponent'.
--
-- @since 0.0.1.0
(//)
:: capture
-> RouteDsl nest capture endpoint ()
-> RouteDsl nest capture endpoint ()
(//) = pathComponent
infixr 5 //
-- | Introduce a nesting point in the route DSL. While the 'pathComponent'
-- function adds the @capture@ to each route defined in the second argument,
-- this one preserves the tree-like structure of the declaration.
--
-- @
-- example :: 'RouteDsl' String String String ()
-- example =
-- 'pathComponent' "thing" $ 'nest' "hello" $ do
-- terminal "first"
-- terminal "second"
-- @
--
-- Calling @'runRouteDsl' example@ would give a data structure like:
--
-- @
-- [ 'PathComponent' "thing" ('Nest'
-- [ Leaf "first"
-- , Leaf "second"
-- ]
-- )
-- ]
-- @
--
-- In constrast, if 'nest' were not called, you would see the 'PathComponent'
-- repeated and distributed to both endpoints.
--
-- @since 0.0.1.0
nest
:: nest
-> RouteDsl nest capture endpoint ()
-> RouteDsl nest capture endpoint ()
nest str = tell . pure . Nest str . runRouteDsl
-- | An infix operator alias for 'nest'.
--
-- @since 0.0.1.0
(/:)
:: nest
-> RouteDsl nest capture endpoint ()
-> RouteDsl nest capture endpoint ()
(/:) = nest
infixr 7 /:
-- | Record the given @endpoint@ as a route.
--
-- @since 0.0.1.0
terminal :: endpoint -> RouteDsl nest capture endpoint ()
terminal = tell . pure . Leaf
-- | Convert a 'RouteTree' into a flattened list of routes. Each @terminal@ is
-- paired with the list of @capture@s that preceeded it.
--
-- @since 0.0.1.0
unnest :: RouteTree nest capture terminal -> [([capture], terminal)]
unnest = go mempty
where
go caps (Leaf term) =
[(DList.toList caps, term)]
go caps (PathComponent cap next) =
go (DList.snoc caps cap) next
go caps (Nest _ xs) =
concatMap (go caps) xs
-- | For efficiency's sake, we encode the route DSL as a 'DList' while defining
-- them, and (for convenience's sake) we present them as an ordinary list when
-- you run it. To prevent type complexity, we parameterize the forest on how
-- we're working with it.
--
-- @since 0.0.1.0
type ForestOf f n capture terminal = f (RouteTree n capture terminal)
-- | A difference list ('DList') of 'RouteTree' values.
--
-- @since 0.0.1.0
type DForest n c t = ForestOf DList n c t
-- | A list of 'RouteTree' values.
--
-- @since 0.0.1.0
type Forest n c t = ForestOf [] n c t
-- | The core data type that is produced by the 'RouteDsl'. If you'd prefer
-- a non-monadic interface to creating these, you're welcome to use the
-- constructors directly.
--
-- The DSL defined as @example@ below has the route representation given by
-- @desugared@:
--
-- @
-- example :: 'Forest' String String String
-- example = 'runRouteDsl' $ do
-- "hello" // do
-- 'terminal' "world"
-- 'terminal' "friend"
-- "nest" /: do
-- 'terminal' "nope"
-- 'terminal' "yes"
--
-- desugared :: 'Forest' String String String
-- desugared =
-- [ 'PathComponent' "hello" ('Leaf' "world")
-- , 'PathComponent' "hello" ('Leaf' "friend")
-- , 'PathComponent' "hello" ('Nest' "nest"
-- [ 'Leaf' "nope"
-- , 'Leaf' "yes"
-- ]
-- )
-- ]
-- @
--
-- @since 0.0.1.0
data RouteTree nest capture terminal
= Leaf terminal
| PathComponent capture (RouteTree nest capture terminal)
| Nest nest [RouteTree nest capture terminal]
deriving (Eq, Show, Functor, Foldable)