Zwaluw (empty) → 0.1

raw patch · 4 files changed

+216/−0 lines, 4 filesdep +basesetup-changed

Dependencies added: base

Files

LICENSE +24/−0
Setup.hs +2/−0
Web/Zwaluw.hs +167/−0
Zwaluw.cabal +23/−0

+ LICENSE view

@@ -0,0 +1,24 @@+Copyright (c) 2008, Sjoerd Visscher & Martijn van Steenbergen+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the author nor the+      names of his contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ Web/Zwaluw.hs view

@@ -0,0 +1,167 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Web.Zwaluw (+    -- * Types+    Router, (:-)(..), (<>),+    +    -- * Running routers+    parse, unparse,+    parse1, unparse1,+    +    -- * Constructing routers+    -- | The @constrN@ functions are helper functions to lift constructors of+    -- datatypes to routers. Their first argument is the constructor; their+    -- second argument is a (partial) destructor.+    constr0, constr1, constr2,+    int, slash, lit+  ) where++import Prelude hiding ((.), id)+import Control.Monad+import Control.Category+import Control.Arrow (first)+import Data.Monoid++infixr 8 <>+infixr 8 :-++-- | Infix operator for 'mappend'.+(<>) :: Monoid m => m -> m -> m+(<>) = mappend++data Router a b = Router+  { ser :: b -> [(a, String)]+  , prs :: String -> [(a -> b, String)] }++data a :- b = a :- b deriving (Eq, Show)++xmap :: (b -> a) -> (a -> b) -> Router r a -> Router r b+xmap f g (Router s p) = Router (s . f) ((fmap . liftM . first . fmap) g p)+  +instance Category (Router) where+  id = lit ""+  Router sf pf . Router sg pg = Router +    (\a -> do+        (b, s) <- sf a+        (c, s') <- sg b+        return (c, s ++ s'))+    (\s -> do+        (f, s') <- pf s+        (g, s'') <- pg s'+        return (f . g, s''))++instance Monoid (Router a b) where+  mempty = Router (const mzero) (const mzero)+  Router sf pf `mappend` Router sg pg = Router +    (\s -> sf s `mplus` sg s)+    (\s -> pf s `mplus` pg s)++parse :: Router () a -> String -> [a]+parse p = concatMap (\(a, s) -> if (s == "") then [a ()] else []) . prs p++parse1 :: Router () (a :- ()) -> String -> [a]+parse1 p s = map (\(r :- ()) -> r) (parse p s)++unparse :: Router () a -> a -> [String]+unparse p = map snd . ser p++unparse1 :: Router () (a :- ()) -> a -> [String]+unparse1 p x = unparse p (x :- ())++maph :: (b -> a) -> (a -> b) -> Router i (a :- o) -> Router i (b :- o)+maph f g = xmap (\(h :- t) -> f h :- t) (\(h :- t) -> g h :- t)++opt :: Eq a => a -> Router r (a :- r) -> Router r (a :- r)+opt a p = p <> push a++nil :: Router r ([a] :- r)+nil = constr0 [] $ \x -> do [] <- x; Just ()++cons :: Router (a :- [a] :- r) ([a] :- r)+cons = constr2 (:) $ \x -> do a:as <- x; return (a, as)++-- many :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r)+-- many p = nil <> many1 p++-- many1 :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r)+-- many1 p = cons . p . many p++satisfy :: (Char -> Bool) -> Router r (Char :- r)+satisfy p = Router+  (\(c :- a) -> if (p c) then return (a, [c]) else mzero)+  (\s -> case s of +    []     -> mzero+    (c:cs) -> if (p c) then return ((c :-), cs) else mzero)++char :: Router r (Char :- r)+char = satisfy (const True)++digitChar :: Router r (Char :- r)+digitChar = satisfy (\c -> c >= '0' && c <= '9')++digit :: Router r (Int :- r)+digit = maph (head . show) (read . (:[])) digitChar+++-- | Routes a constant string.+lit :: String -> Router r r+lit l = Router+  (\b -> return (b, l))+  (\s -> let (s1, s2) = splitAt (length l) s in if s1 == l then return (id, s2) else mzero)++-- | Routes a slash.+slash :: Router r r+slash = lit "/"++-- | Routes any integer.+int :: Router r (Int :- r)+-- int = maph show read $ many1 digitChar+int = Router+  (\(i :- a) -> return (a, show i))+  (\s -> let l = reads s in map (first (:-)) l)++++push :: Eq h => h -> Router r (h :- r)+push h = Router +  (\(h' :- t) -> do guard (h == h'); return (t, ""))+  (\s -> return ((h :-), s))++left :: Router (a :- r) (Either a b :- r)+left = constr1 Left $ \x -> do Left a <- x; return a++right :: Router (b :- r) (Either a b :- r)+right = constr1 Right $ \x -> do Right b <- x; return b++eitherP :: Router r (a :- r) -> Router r (b :- r) -> Router r (Either a b :- r)+eitherP l r = left . l <> right . r++-- | For example:+-- +-- > nil :: Router r ([a] :- r)+-- > nil = constr0 [] $ \x -> do [] <- x; Just ()+constr0 :: o -> (Maybe o -> Maybe ()) -> Router r (o :- r)+constr0 c d = Router +  (\(a :- t) -> maybe mzero (\_ -> return (t, "")) (d (return a)))+  (\s -> return ((c :-), s))++-- | For example:+--+-- > left :: Router (a :- r) (Either a b :- r)+-- > left = constr1 Left $ \x -> do Left a <- x; return a+constr1 :: (a -> o) -> (Maybe o -> Maybe a) -> Router (a :- r) (o :- r)+constr1 c d = Router+  (\(a :- t) -> maybe mzero (\a -> return (a :- t, "")) (d (return a)))+  (\s -> return (\(a :- t) -> c a :- t, s))++-- | For example:+--+-- > cons :: Router (a :- [a] :- r) ([a] :- r)+-- > cons = constr2 (:) $ \x -> do a:as <- x; return (a, as)+constr2 :: (a -> b -> o) -> (Maybe o -> Maybe (a, b)) ->+  Router (a :- b :- r) (o :- r)+constr2 c d = Router+  (\(a :- t) ->+    maybe mzero (\(a, b) -> return (a :- b :- t, "")) (d (return a)))+  (\s -> return (\(a :- b :- t) -> c a b :- t, s))

+ Zwaluw.cabal view

@@ -0,0 +1,23 @@+Name:           Zwaluw+Version:        0.1+Synopsis:       Combinators for bidirectional URL routing+Description:   	Combinators for bidirectional URL routing+++Author:         Sjoerd Visscher, Martijn van Steenbergen+Maintainer:     martijn@van.steenbergen.nl+Stability:      Experimental+Copyright:      Some Rights Reserved (CC) 2010 Sjoerd Visscher, Martijn van Steenbergen+Homepage:       https://github.com/MedeaMelana/Zwaluw+++Cabal-Version:  >= 1.2+License:        BSD3+License-file:   LICENSE+Category:       Text+Build-type:     Simple+++Library+  Exposed-Modules:  Web.Zwaluw+  Build-Depends:    base >= 4 && < 5