Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 0c3d23efad
Fetching contributors…

Cannot retrieve contributors at this time

213 lines (163 sloc) 6.822 kb
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
module Web.Zwaluw (
-- * Types
Router, (:-)(..), (<>), (.~)
-- * Running routers
, parse, unparse
, parse1, unparse1
-- * Router combinators
, pure, xmap, xmaph
, val, readshow, lit, push
, opt, duck, satisfy, rFilter, printAs
, manyr, somer, chainr, chainr1
, manyl, somel, chainl, chainl1
-- * Built-in routers
, int, integer, string, text, char, digit, hexDigit
, (/), part
, rNil, rCons, rList, rListSep
, rPair
, rLeft, rRight, rEither
, rNothing, rJust, rMaybe
, rTrue, rFalse
-- * FilePath data type and router
, FilePath, filePath
) where
import Prelude hiding ((.), id, (/), FilePath)
import Control.Monad (guard)
import Control.Category
import Data.Monoid
import Data.Char (isDigit, isHexDigit, intToDigit, digitToInt)
import qualified Data.Text as T
import Web.Zwaluw.Core
import Web.Zwaluw.TH
infixr 8 <>
-- | Infix operator for 'mappend'.
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
-- | Make a router optional.
opt :: Router r r -> Router r r
opt = (id <>)
-- | Repeat a router zero or more times, combining the results from left to right.
manyr :: Router r r -> Router r r
manyr = opt . somer
-- | Repeat a router one or more times, combining the results from left to right.
somer :: Router r r -> Router r r
somer p = p . manyr p
-- | @chainr p op@ repeats @p@ zero or more times, separated by @op@.
-- The result is a right associative fold of the results of @p@ with the results of @op@.
chainr :: Router r r -> Router r r -> Router r r
chainr p op = opt (manyr (p .~ op) . p)
-- | @chainr1 p op@ repeats @p@ one or more times, separated by @op@.
-- The result is a right associative fold of the results of @p@ with the results of @op@.
chainr1 :: Router r (a :- r) -> Router (a :- a :- r) (a :- r) -> Router r (a :- r)
chainr1 p op = manyr (duck1 p .~ op) . p
-- | Repeat a router zero or more times, combining the results from right to left.
manyl :: Router r r -> Router r r
manyl = opt . somel
-- | Repeat a router one or more times, combining the results from right to left.
somel :: Router r r -> Router r r
somel p = p .~ manyl p
-- | @chainl1 p op@ repeats @p@ zero or more times, separated by @op@.
-- The result is a left associative fold of the results of @p@ with the results of @op@.
chainl :: Router r r -> Router r r -> Router r r
chainl p op = opt (p .~ manyl (op . p))
-- | @chainl1 p op@ repeats @p@ one or more times, separated by @op@.
-- The result is a left associative fold of the results of @p@ with the results of @op@.
chainl1 :: Router r (a :- r) -> Router (a :- a :- r) (a :- r) -> Router r (a :- r)
chainl1 p op = p .~ manyl (op . duck p)
-- | Filtering on routers.
rFilter :: (a -> Bool) -> Router () (a :- ()) -> Router r (a :- r)
rFilter p r = val
(\s -> [ (a, s') | (f, s') <- prs r s, let a = hhead (f ()), p a ])
(\a -> [ f | p a, (f, _) <- ser r (a :- ()) ])
-- | Push a value on the stack (during parsing, pop it from the stack when serializing).
push :: Eq a => a -> Router r (a :- r)
push a = pure (a :-) (\(a' :- t) -> guard (a' == a) >> Just t)
-- | Routes any value that has a Show and Read instance.
readshow :: (Show a, Read a) => Router r (a :- r)
readshow = val reads (return . shows)
-- | Routes any @Int@.
int :: Router r (Int :- r)
int = readshow
-- | Routes any @Integer@.
integer :: Router r (Integer :- r)
integer = readshow
-- | Routes any non-empty string, upto a slash ("/").
string :: Router r (String :- r)
string = val parse' serialize
where
parse' "" = []
parse' s = [( takeWhile (/= '/') s
, dropWhile (/= '/') s
)]
serialize = return . (++)
-- | Routes any non-empty text, upto a slash ("/").
text :: Router r (T.Text :- r)
text = val parse' serialize
where
parse' "" = []
parse' s = [( T.pack . takeWhile (/= '/') $ s
, dropWhile (/= '/') s
)]
serialize = return . (++) . T.unpack
-- | Routes one character satisfying the given predicate.
satisfy :: (Char -> Bool) -> Router r (Char :- r)
satisfy p = val
(\s -> [ (c, cs) | c:cs <- [s], p c ])
(\c -> [ (c :) | p c ])
-- | Routes one character.
char :: Router r (Char :- r)
char = satisfy (const True)
-- | Routes one decimal digit.
digit :: Router r (Int :- r)
digit = xmaph digitToInt (\i -> guard (i >= 0 && i < 10) >> Just (intToDigit i)) (satisfy isDigit)
-- | Routes one hexadecimal digit.
hexDigit :: Router r (Int :- r)
hexDigit = xmaph digitToInt (\i -> guard (i >= 0 && i < 16) >> Just (intToDigit i)) (satisfy isHexDigit)
infixr 9 /
-- | @p \/ q@ is equivalent to @p . \"\/\" . q@.
(/) :: Router b c -> Router a b -> Router a c
(/) f g = f . lit "/" . g
-- | Routes part of a URL, i.e. a String not containing @\'\/\'@ or @\'\?\'@.
part :: Router r (String :- r)
part = rList (satisfy (\c -> c /= '/' && c /= '?'))
rNil :: Router r ([a] :- r)
rNil = pure ([] :-) $ \(xs :- t) -> do [] <- Just xs; Just t
rCons :: Router (a :- [a] :- r) ([a] :- r)
rCons = pure (arg (arg (:-)) (:)) $ \(xs :- t) -> do a:as <- Just xs; Just (a :- as :- t)
-- | Converts a router for a value @a@ to a router for a list of @a@.
rList :: Router r (a :- r) -> Router r ([a] :- r)
rList r = manyr (rCons . duck1 r) . rNil
-- | Converts a router for a value @a@ to a router for a list of @a@, with a separator.
rListSep :: Router r (a :- r) -> Router ([a] :- r) ([a] :- r) -> Router r ([a] :- r)
rListSep r sep = chainr (rCons . duck1 r) sep . rNil
rPair :: Router (f :- s :- r) ((f, s) :- r)
rPair = pure (arg (arg (:-)) (,)) $ \(ab :- t) -> do (a,b) <- Just ab; Just (a :- b :- t)
$(deriveRouters ''Either)
rLeft :: Router (a :- r) (Either a b :- r)
rRight :: Router (b :- r) (Either a b :- r)
-- | Combines a router for a value @a@ and a router for a value @b@ into a router for @Either a b@.
rEither :: Router r (a :- r) -> Router r (b :- r) -> Router r (Either a b :- r)
rEither l r = rLeft . l <> rRight . r
$(deriveRouters ''Maybe)
rNothing :: Router r (Maybe a :- r)
rJust :: Router (a :- r) (Maybe a :- r)
-- | Converts a router for a value @a@ to a router for a @Maybe a@.
rMaybe :: Router r (a :- r) -> Router r (Maybe a :- r)
rMaybe r = rJust . r <> rNothing
$(deriveRouters ''Bool)
rTrue :: Router r (Bool :- r)
rFalse :: Router r (Bool :- r)
-- | Represents a file path, including slashes
newtype FilePath = FilePath { unFilePath :: T.Text }
instance Show FilePath where
showsPrec p (FilePath t) r = showsPrec p t r
filePath :: Router r (FilePath :- r)
filePath = val parse' serialize
where
parse' "" = []
parse' s = [(FilePath . T.pack $ s, "")]
serialize = return . (++) . T.unpack . unFilePath
Jump to Line
Something went wrong with that request. Please try again.