diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +reroute +===== + +[![Build Status](https://travis-ci.org/agrafix/reroute.svg)](https://travis-ci.org/agrafix/reroute) + +[![Hackage Deps](https://img.shields.io/hackage-deps/v/reroute.svg)](http://packdeps.haskellers.com/reverse/reroute) + +# Intro + +Hackage: http://hackage.haskell.org/package/reroute + +An abstract implementation of typesafe and untyped routing for web applications. The web framework +[Spock](https://github.com/agrafix/Spock) is implemented with it. The basic idea is you have a +registry storing a mapping betwenn abstract routes and actions. Then you define two methods for +adding a route and it's action to the registry and a second method for efficiently matching a +provided path to a route and multiple actions. + +# Install + +* Using cabal: `cabal install reroute` +* From Source: `git clone https://github.com/agrafix/reroute.git && cd reroute && cabal install` diff --git a/reroute.cabal b/reroute.cabal --- a/reroute.cabal +++ b/reroute.cabal @@ -1,5 +1,5 @@ name: reroute -version: 0.2.3.0 +version: 0.3.0.1 synopsis: abstract implementation of typed and untyped web routing description: abstraction over how urls with/without parameters are mapped to their corresponding handlers homepage: http://github.com/agrafix/reroute @@ -12,9 +12,11 @@ build-type: Simple cabal-version: >=1.10 +extra-source-files: + README.md + library exposed-modules: - Data.HVect, Data.PolyMap, Web.Routing.AbstractRouter, Web.Routing.SafeRouting, @@ -30,7 +32,8 @@ text >= 0.11.3.1, transformers >=0.3, unordered-containers >=0.2, - vector >=0.10 + vector >=0.10, + hvect >=0.1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans @@ -50,7 +53,8 @@ reroute, text, unordered-containers, - vector + vector, + hvect default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans @@ -72,7 +76,8 @@ random, deepseq, path-pieces, - graph-core + graph-core, + hvect source-repository head type: git diff --git a/src/Data/HVect.hs b/src/Data/HVect.hs deleted file mode 100644 --- a/src/Data/HVect.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE UndecidableInstances #-} -- for ReverseLoop type family -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} - -module Data.HVect - ( HVect (..) - , HVectElim - , Append, hVectAppend - , ReverseLoop, Reverse, hVectReverse - , hVectUncurry - , Rep (..), HasRep (..) - , hVectCurryExpl, hVectCurry - , packExpl, pack - ) where - -data HVect (ts :: [*]) where - HNil :: HVect '[] - HCons :: t -> HVect ts -> HVect (t ': ts) - --- todo: use a closed type family once GHC 7.6 compatibility is dropped -type family HVectElim (ts :: [*]) (a :: *) :: * -type instance HVectElim '[] a = a -type instance HVectElim (t ': ts) a = t -> HVectElim ts a - --- todo: use a closed type family once GHC 7.6 compatibility is dropped -type family Append (as :: [*]) (bs :: [*]) :: [*] -type instance Append '[] bs = bs -type instance Append (a ': as) bs = a ': (Append as bs) - -hVectAppend :: HVect as -> HVect bs -> HVect (Append as bs) -hVectAppend HNil bs = bs -hVectAppend (HCons a as) bs = HCons a (hVectAppend as bs) - -type family ReverseLoop (as :: [*]) (bs :: [*]) :: [*] -type instance ReverseLoop '[] bs = bs -type instance ReverseLoop (a ': as) bs = ReverseLoop as (a ': bs) - -type Reverse as = ReverseLoop as '[] - -hVectReverse :: HVect as -> HVect (Reverse as) -hVectReverse vs = go vs HNil - where - go :: HVect as -> HVect bs -> HVect (ReverseLoop as bs) - go HNil bs = bs - go (HCons a as) bs = go as (HCons a bs) - -hVectUncurry :: HVectElim ts a -> HVect ts -> a -hVectUncurry f HNil = f -hVectUncurry f (HCons x xs) = hVectUncurry (f x) xs - -data Rep (ts :: [*]) where - RNil :: Rep '[] - RCons :: Rep ts -> Rep (t ': ts) - -class HasRep (ts :: [*]) where - hasRep :: Rep ts - -instance HasRep '[] where - hasRep = RNil - -instance HasRep ts => HasRep (t ': ts) where - hasRep = RCons hasRep - -hVectCurryExpl :: Rep ts -> (HVect ts -> a) -> HVectElim ts a -hVectCurryExpl RNil f = f HNil -hVectCurryExpl (RCons r) f = \x -> hVectCurryExpl r (f . HCons x) - -hVectCurry :: HasRep ts => (HVect ts -> a) -> HVectElim ts a -hVectCurry = hVectCurryExpl hasRep - -buildElim :: Rep ts -> (HVect ts -> HVect ss) -> HVectElim ts (HVect ss) -buildElim RNil f = f HNil -buildElim (RCons r) f = \x -> buildElim r (f . HCons x) - -packExpl :: Rep ts -> (forall a. HVectElim ts a -> a) -> HVect ts -packExpl rep f = f (buildElim rep id) - -pack :: HasRep ts => (forall a. HVectElim ts a -> a) -> HVect ts -pack = packExpl hasRep diff --git a/src/Web/Routing/SafeRouting.hs b/src/Web/Routing/SafeRouting.hs --- a/src/Web/Routing/SafeRouting.hs +++ b/src/Web/Routing/SafeRouting.hs @@ -8,7 +8,8 @@ module Web.Routing.SafeRouting where import qualified Data.PolyMap as PM -import Data.HVect +import Data.HVect hiding (null) +import qualified Data.HVect as HV import Web.Routing.AbstractRouter import Data.Maybe @@ -104,15 +105,15 @@ let subPathMap = fromMaybe emptyPathMap (HM.lookup pathPiece s) in PathMap h (HM.insert pathPiece (insertPathMap' path' action subPathMap) s) p VarCons path' -> - let alterFn = Just . insertPathMap' path' (\vs v -> action (HCons v vs)) + let alterFn = Just . insertPathMap' path' (\vs v -> action (v :&: vs)) . fromMaybe emptyPathMap in PathMap h s (PM.alter alterFn p) singleton :: Path ts -> HVectElim ts x -> PathMap x -singleton path action = insertPathMap' path (hVectUncurry action) mempty +singleton path action = insertPathMap' path (HV.uncurry action) mempty insertPathMap :: RouteHandle m a -> PathMap (m a) -> PathMap (m a) -insertPathMap (RouteHandle path action) = insertPathMap' path (hVectUncurry action) +insertPathMap (RouteHandle path action) = insertPathMap' path (HV.uncurry action) match :: PathMap x -> [T.Text] -> [x] match (PathMap h _ _) [] = h @@ -154,7 +155,7 @@ renderRoute' Empty _ = [] renderRoute' (StaticCons pathPiece pathXs) paramXs = ( pathPiece : renderRoute' pathXs paramXs ) -renderRoute' (VarCons pathXs) (HCons val paramXs) = +renderRoute' (VarCons pathXs) (val :&: paramXs) = ( toPathPiece val : renderRoute' pathXs paramXs) renderRoute' _ _ = error "This will never happen." @@ -174,4 +175,4 @@ Nothing -> Nothing Just val -> let finish = parse pathXs xs - in fmap (\parsedXs -> HCons val parsedXs) finish + in fmap (\parsedXs -> val :&: parsedXs) finish diff --git a/test/Web/Routing/SafeRoutingSpec.hs b/test/Web/Routing/SafeRoutingSpec.hs --- a/test/Web/Routing/SafeRoutingSpec.hs +++ b/test/Web/Routing/SafeRoutingSpec.hs @@ -5,7 +5,7 @@ module Web.Routing.SafeRoutingSpec where import Test.Hspec -import Data.HVect +import Data.HVect hiding (singleton) import Control.Monad.Identity import Web.Routing.SafeRouting