[Pkg-haskell-commits] darcs: haskell-yesod-routes: Initial Check-In
Clint Adams
clint at debian.org
Thu Mar 1 01:27:41 UTC 2012
Thu Mar 1 01:27:15 UTC 2012 Clint Adams <clint at debian.org>
* Initial Check-In
Ignore-this: 53d92d489c1260c2d78f729c3658a692
A ./changelog
A ./compat
A ./control
A ./copyright
A ./patches/
A ./patches/series
A ./patches/testsuite.diff
A ./rules
A ./source/
A ./source/format
A ./watch
Thu Mar 1 01:27:15 UTC 2012 Clint Adams <clint at debian.org>
* Initial Check-In
Ignore-this: 53d92d489c1260c2d78f729c3658a692
diff -rN -u old-haskell-yesod-routes//changelog new-haskell-yesod-routes//changelog
--- old-haskell-yesod-routes//changelog 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-yesod-routes//changelog 2012-03-01 01:27:41.659260216 +0000
@@ -0,0 +1,6 @@
+haskell-yesod-routes (0.0.1-1) unstable; urgency=low
+
+ * Initial release.
+
+ -- Clint Adams <clint at debian.org> Wed, 29 Feb 2012 20:03:17 -0500
+
diff -rN -u old-haskell-yesod-routes//compat new-haskell-yesod-routes//compat
--- old-haskell-yesod-routes//compat 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-yesod-routes//compat 2012-03-01 01:27:41.663251549 +0000
@@ -0,0 +1 @@
+7
\ No newline at end of file
diff -rN -u old-haskell-yesod-routes//control new-haskell-yesod-routes//control
--- old-haskell-yesod-routes//control 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-yesod-routes//control 2012-03-01 01:27:41.663251549 +0000
@@ -0,0 +1,64 @@
+Source: haskell-yesod-routes
+Priority: extra
+Section: haskell
+Maintainer: Clint Adams <clint at debian.org>
+Build-Depends: debhelper (>= 7.0)
+ , haskell-devscripts (>= 0.8.10)
+ , cdbs
+ , ghc
+ , ghc-prof
+ , ghc-ghci
+ , libghc-path-pieces-dev (>> 0.1)
+ , libghc-path-pieces-dev (<< 0.2)
+ , libghc-path-pieces-prof
+ , libghc-text-dev (>> 0.5)
+ , libghc-text-dev (<< 0.12)
+ , libghc-text-prof
+ , libghc-vector-dev (>> 0.8)
+ , libghc-vector-dev (<< 0.10)
+ , libghc-vector-prof
+ , libghc-hunit-dev
+ , libghc-hspec-dev
+Build-Depends-Indep: ghc-doc
+ , libghc-path-pieces-doc
+ , libghc-text-doc
+ , libghc-vector-doc
+Standards-Version: 3.9.3
+Homepage: http://www.yesodweb.com/
+
+Package: libghc-yesod-routes-dev
+Architecture: any
+Depends: ${shlibs:Depends},
+ ${haskell:Depends},
+ ${misc:Depends}
+Recommends: ${haskell:Recommends}
+Suggests: ${haskell:Suggests}
+Provides: ${haskell:Provides}
+Description: efficient routing for Yesod
+ Provides an efficient routing system, a parser and TH code generation.
+ .
+ This package contains the normal library files.
+
+Package: libghc-yesod-routes-prof
+Architecture: any
+Depends: ${haskell:Depends},
+ ${misc:Depends}
+Recommends: ${haskell:Recommends}
+Suggests: ${haskell:Suggests}
+Provides: ${haskell:Provides}
+Description: efficient routing for Yesod; profiling libraries
+ Provides an efficient routing system, a parser and TH code generation.
+ .
+ This package contains the libraries compiled with profiling enabled.
+
+Package: libghc-yesod-routes-doc
+Architecture: all
+Section: doc
+Depends: ${haskell:Depends},
+ ${misc:Depends}
+Recommends: ${haskell:Recommends}
+Suggests: ${haskell:Suggests}
+Description: efficient routing for Yesod; documentation
+ Provides an efficient routing system, a parser and TH code generation.
+ .
+ This package contains the documentation files.
diff -rN -u old-haskell-yesod-routes//copyright new-haskell-yesod-routes//copyright
--- old-haskell-yesod-routes//copyright 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-yesod-routes//copyright 2012-03-01 01:27:41.663251549 +0000
@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. 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.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 THE COPYRIGHT HOLDERS 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.
diff -rN -u old-haskell-yesod-routes//patches/series new-haskell-yesod-routes//patches/series
--- old-haskell-yesod-routes//patches/series 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-yesod-routes//patches/series 2012-03-01 01:27:41.663251549 +0000
@@ -0,0 +1 @@
+testsuite.diff
diff -rN -u old-haskell-yesod-routes//patches/testsuite.diff new-haskell-yesod-routes//patches/testsuite.diff
--- old-haskell-yesod-routes//patches/testsuite.diff 1970-01-01 00:00:00.000000000 +0000
+++ new-haskell-yesod-routes//patches/testsuite.diff 2012-03-01 01:27:41.663251549 +0000
@@ -0,0 +1,345 @@
+--- /dev/null
++++ b/test/main.hs
+@@ -0,0 +1,342 @@
++{-# LANGUAGE TemplateHaskell #-}
++{-# LANGUAGE TypeFamilies #-}
++{-# LANGUAGE FlexibleInstances #-}
++{-# LANGUAGE ExistentialQuantification #-}
++{-# LANGUAGE MultiParamTypeClasses #-}
++{-# LANGUAGE RankNTypes #-}
++{-# LANGUAGE FunctionalDependencies #-}
++{-# LANGUAGE TypeSynonymInstances #-}
++{-# LANGUAGE QuasiQuotes #-}
++{-# LANGUAGE CPP #-}
++import Test.Hspec.Monadic
++import Test.Hspec.HUnit ()
++import Test.HUnit ((@?=))
++import Data.Text (Text, pack, unpack, singleton)
++import Yesod.Routes.Dispatch hiding (Static, Dynamic)
++import Yesod.Routes.Class hiding (Route)
++import qualified Yesod.Routes.Class as YRC
++import qualified Yesod.Routes.Dispatch as D
++import Yesod.Routes.Parse (parseRoutesNoCheck)
++import Yesod.Routes.Overlap (findOverlapNames)
++import Yesod.Routes.TH hiding (Dispatch)
++import Language.Haskell.TH.Syntax
++
++class ToText a where
++ toText :: a -> Text
++
++instance ToText Text where toText = id
++instance ToText String where toText = pack
++
++result :: ([Text] -> Maybe Int) -> Dispatch Int
++result f ts = f ts
++
++justRoot :: Dispatch Int
++justRoot = toDispatch
++ [ Route [] False $ result $ const $ Just 1
++ ]
++
++twoStatics :: Dispatch Int
++twoStatics = toDispatch
++ [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 2
++ , Route [D.Static $ pack "bar"] False $ result $ const $ Just 3
++ ]
++
++multi :: Dispatch Int
++multi = toDispatch
++ [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 4
++ , Route [D.Static $ pack "bar"] True $ result $ const $ Just 5
++ ]
++
++dynamic :: Dispatch Int
++dynamic = toDispatch
++ [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 6
++ , Route [D.Dynamic] False $ result $ \ts ->
++ case ts of
++ [t] ->
++ case reads $ unpack t of
++ [] -> Nothing
++ (i, _):_ -> Just i
++ _ -> error $ "Called dynamic with: " ++ show ts
++ ]
++
++overlap :: Dispatch Int
++overlap = toDispatch
++ [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 20
++ , Route [D.Static $ pack "foo"] True $ result $ const $ Just 21
++ , Route [] True $ result $ const $ Just 22
++ ]
++
++test :: Dispatch Int -> [String] -> Maybe Int
++test dispatch ts = dispatch $ map pack ts
++
++data MyApp = MyApp
++
++data MySub = MySub
++instance RenderRoute MySub where
++ data
++#if MIN_VERSION_base(4,5,0)
++ Route
++#else
++ YRC.Route
++#endif
++ MySub = MySubRoute ([Text], [(Text, Text)])
++ deriving (Show, Eq, Read)
++ renderRoute (MySubRoute x) = x
++
++getMySub :: MyApp -> MySub
++getMySub MyApp = MySub
++
++data MySubParam = MySubParam Int
++instance RenderRoute MySubParam where
++ data
++#if MIN_VERSION_base(4,5,0)
++ Route
++#else
++ YRC.Route
++#endif
++ MySubParam = ParamRoute Char
++ deriving (Show, Eq, Read)
++ renderRoute (ParamRoute x) = ([singleton x], [])
++
++getMySubParam :: MyApp -> Int -> MySubParam
++getMySubParam _ = MySubParam
++
++type Handler sub master = Text
++type App sub master = (Text, Maybe (YRC.Route master))
++
++class Dispatcher sub master where
++ dispatcher
++ :: master
++ -> sub
++ -> (YRC.Route sub -> YRC.Route master)
++ -> App sub master -- ^ 404 page
++ -> (YRC.Route sub -> App sub master) -- ^ 405 page
++ -> Text -- ^ method
++ -> [Text]
++ -> App sub master
++
++class RunHandler sub master where
++ runHandler
++ :: Handler sub master
++ -> master
++ -> sub
++ -> Maybe (YRC.Route sub)
++ -> (YRC.Route sub -> YRC.Route master)
++ -> App sub master
++
++do
++ texts <- [t|[Text]|]
++ let ress =
++ [ Resource "RootR" [] $ Methods Nothing ["GET"]
++ , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"]
++ , Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) []
++ , Resource "SubsiteR" (addCheck [Static "subsite"]) $ Subsite (ConT ''MySub) "getMySub"
++ , Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) $ Subsite (ConT ''MySubParam) "getMySubParam"
++ ]
++ addCheck = map ((,) True)
++ rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
++ dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
++ return
++ [ rrinst
++ , InstanceD
++ []
++ (ConT ''Dispatcher
++ `AppT` ConT ''MyApp
++ `AppT` ConT ''MyApp)
++ [FunD (mkName "dispatcher") [dispatch]]
++ ]
++
++instance RunHandler MyApp master where
++ runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
++
++instance Dispatcher MySub master where
++ dispatcher _ _ toMaster _ _ _ pieces = (pack $ "subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
++
++instance Dispatcher MySubParam master where
++ dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
++ case map unpack pieces of
++ [[c]] -> (pack $ "subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
++ _ -> app404
++
++{-
++thDispatchAlias
++ :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp)))
++ => master
++ -> sub
++ -> (YRC.Route sub -> YRC.Route master)
++ -> app -- ^ 404 page
++ -> handler -- ^ 405 page
++ -> Text -- ^ method
++ -> [Text]
++ -> app
++--thDispatchAlias = thDispatch
++thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
++ case dispatch pieces0 of
++ Just f -> f master sub toMaster app404 handler405 method0
++ Nothing -> app404
++ where
++ dispatch = toDispatch
++ [ Route [] False $ \pieces ->
++ case pieces of
++ [] -> do
++ Just $ \master' sub' toMaster' _app404' handler405' method ->
++ let handler =
++ case Map.lookup method methodsRootR of
++ Just f -> f
++ Nothing -> handler405'
++ in runHandler handler master' sub' RootR toMaster'
++ _ -> error "Invariant violated"
++ , Route [D.Static "blog", D.Dynamic] False $ \pieces ->
++ case pieces of
++ [_, x2] -> do
++ y2 <- fromPathPiece x2
++ Just $ \master' sub' toMaster' _app404' handler405' method ->
++ let handler =
++ case Map.lookup method methodsBlogPostR of
++ Just f -> f y2
++ Nothing -> handler405'
++ in runHandler handler master' sub' (BlogPostR y2) toMaster'
++ _ -> error "Invariant violated"
++ , Route [D.Static "wiki"] True $ \pieces ->
++ case pieces of
++ _:x2 -> do
++ y2 <- fromPathMultiPiece x2
++ Just $ \master' sub' toMaster' _app404' _handler405' _method ->
++ let handler = handleWikiR y2
++ in runHandler handler master' sub' (WikiR y2) toMaster'
++ _ -> error "Invariant violated"
++ , Route [D.Static "subsite"] True $ \pieces ->
++ case pieces of
++ _:x2 -> do
++ Just $ \master' sub' toMaster' app404' handler405' method ->
++ dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2
++ _ -> error "Invariant violated"
++ , Route [D.Static "subparam", D.Dynamic] True $ \pieces ->
++ case pieces of
++ _:x2:x3 -> do
++ y2 <- fromPathPiece x2
++ Just $ \master' sub' toMaster' app404' handler405' method ->
++ dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3
++ _ -> error "Invariant violated"
++ ]
++ methodsRootR = Map.fromList [("GET", getRootR)]
++ methodsBlogPostR = Map.fromList [("GET", getBlogPostR), ("POST", postBlogPostR)]
++-}
++
++main :: IO ()
++main = hspecX $ do
++ describe "justRoot" $ do
++ it "dispatches correctly" $ test justRoot [] @?= Just 1
++ it "fails correctly" $ test justRoot ["foo"] @?= Nothing
++ describe "twoStatics" $ do
++ it "dispatches correctly to foo" $ test twoStatics ["foo"] @?= Just 2
++ it "dispatches correctly to bar" $ test twoStatics ["bar"] @?= Just 3
++ it "fails correctly (1)" $ test twoStatics [] @?= Nothing
++ it "fails correctly (2)" $ test twoStatics ["bar", "baz"] @?= Nothing
++ describe "multi" $ do
++ it "dispatches correctly to foo" $ test multi ["foo"] @?= Just 4
++ it "dispatches correctly to bar" $ test multi ["bar"] @?= Just 5
++ it "dispatches correctly to bar/baz" $ test multi ["bar", "baz"] @?= Just 5
++ it "fails correctly (1)" $ test multi [] @?= Nothing
++ it "fails correctly (2)" $ test multi ["foo", "baz"] @?= Nothing
++ describe "dynamic" $ do
++ it "dispatches correctly to foo" $ test dynamic ["foo"] @?= Just 6
++ it "dispatches correctly to 7" $ test dynamic ["7"] @?= Just 7
++ it "dispatches correctly to 42" $ test dynamic ["42"] @?= Just 42
++ it "fails correctly on five" $ test dynamic ["five"] @?= Nothing
++ it "fails correctly on too many" $ test dynamic ["foo", "baz"] @?= Nothing
++ it "fails correctly on too few" $ test dynamic [] @?= Nothing
++ describe "overlap" $ do
++ it "dispatches correctly to foo" $ test overlap ["foo"] @?= Just 20
++ it "dispatches correctly to foo/bar" $ test overlap ["foo", "bar"] @?= Just 21
++ it "dispatches correctly to bar" $ test overlap ["bar"] @?= Just 22
++ it "dispatches correctly to []" $ test overlap [] @?= Just 22
++
++ describe "RenderRoute instance" $ do
++ it "renders root correctly" $ renderRoute RootR @?= ([], [])
++ it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], [])
++ it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], [])
++ it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")]))
++ @?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")])
++ it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c')
++ @?= (map pack ["subparam", "6", "c"], [])
++
++ describe "thDispatch" $ do
++ let disp m ps = dispatcher MyApp MyApp id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
++ it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR)
++ it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR)
++ it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing)
++ it "routes to blog post" $ disp "GET" ["blog", "somepost"]
++ @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost")
++ it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]
++ @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2")
++ it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"]
++ @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"])
++ it "routes to subsite" $ disp "PUT" ["subsite", "baz"]
++ @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], []))
++ it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]
++ @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
++
++ describe "overlap checking" $ do
++ it "catches overlapping statics" $ do
++ let routes = [parseRoutesNoCheck|
++/foo Foo1
++/foo Foo2
++|]
++ findOverlapNames routes @?= [("Foo1", "Foo2")]
++ it "catches overlapping dynamics" $ do
++ let routes = [parseRoutesNoCheck|
++/#Int Foo1
++/#String Foo2
++|]
++ findOverlapNames routes @?= [("Foo1", "Foo2")]
++ it "catches overlapping statics and dynamics" $ do
++ let routes = [parseRoutesNoCheck|
++/foo Foo1
++/#String Foo2
++|]
++ findOverlapNames routes @?= [("Foo1", "Foo2")]
++ it "catches overlapping multi" $ do
++ let routes = [parseRoutesNoCheck|
++/foo Foo1
++/##*Strings Foo2
++|]
++ findOverlapNames routes @?= [("Foo1", "Foo2")]
++ it "catches overlapping subsite" $ do
++ let routes = [parseRoutesNoCheck|
++/foo Foo1
++/foo Foo2 Subsite getSubsite
++|]
++ findOverlapNames routes @?= [("Foo1", "Foo2")]
++ it "no false positives" $ do
++ let routes = [parseRoutesNoCheck|
++/foo Foo1
++/bar/#String Foo2
++|]
++ findOverlapNames routes @?= []
++ it "obeys ignore rules" $ do
++ let routes = [parseRoutesNoCheck|
++/foo Foo1
++/#!String Foo2
++/!foo Foo3
++|]
++ findOverlapNames routes @?= []
++ it "[...incomplete...]
More information about the Pkg-haskell-commits
mailing list