Switch to Literate Haskell
This commit is contained in:
Michael Snoyman
parent
29a9bfd7e8
commit
1a40b16e4c
@ -1,112 +0,0 @@
|
|||||||
module Yesod.Routes
|
|
||||||
( Piece (..)
|
|
||||||
, RouteHandler (..)
|
|
||||||
, Dispatch
|
|
||||||
, toDispatch
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Text (Text)
|
|
||||||
import qualified Data.Vector as V
|
|
||||||
import Data.Maybe (fromMaybe, mapMaybe)
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
import Data.List (sortBy)
|
|
||||||
import Data.Ord (comparing)
|
|
||||||
import Control.Arrow (second)
|
|
||||||
|
|
||||||
data Piece = StaticPiece Text | SinglePiece
|
|
||||||
type Dispatch req res = [Text] -> req -> Maybe res
|
|
||||||
|
|
||||||
data RouteHandler req res = RouteHandler
|
|
||||||
{ rhPieces :: [Piece]
|
|
||||||
, rhHasMulti :: Bool
|
|
||||||
, rhDispatch :: Dispatch req res
|
|
||||||
}
|
|
||||||
|
|
||||||
toDispatch :: [RouteHandler req res] -> [Text] -> req -> Maybe res
|
|
||||||
toDispatch rhs =
|
|
||||||
bcToDispatch bc
|
|
||||||
where
|
|
||||||
bc = toBC rhs
|
|
||||||
|
|
||||||
bcToDispatch :: ByCount req res -> Dispatch req res
|
|
||||||
bcToDispatch (ByCount vec rest) ts0 req =
|
|
||||||
bcToDispatch' ts0 pm0
|
|
||||||
where
|
|
||||||
--pm0 :: PieceMap sub master res
|
|
||||||
pm0 = fromMaybe rest $ vec V.!? length ts0
|
|
||||||
|
|
||||||
--bcToDispatch' :: [Text] -> PieceMap req res -> Maybe res
|
|
||||||
bcToDispatch' _ (PieceMapEnd r) =
|
|
||||||
firstJust (\f -> f ts0 req) $ map snd $ sortBy (comparing fst) r
|
|
||||||
bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $
|
|
||||||
case Map.lookup t sta of
|
|
||||||
Nothing -> dyn
|
|
||||||
Just pm -> append dyn pm
|
|
||||||
bcToDispatch' [] _ = Nothing
|
|
||||||
|
|
||||||
firstJust :: (a -> Maybe b) -> [a] -> Maybe b
|
|
||||||
firstJust _ [] = Nothing
|
|
||||||
firstJust f (a:as) = maybe (firstJust f as) Just $ f a
|
|
||||||
|
|
||||||
append :: PieceMap a b -> PieceMap a b -> PieceMap a b
|
|
||||||
append (PieceMapEnd a) (PieceMapEnd b) = PieceMapEnd $ a ++ b
|
|
||||||
append (PieceMap a x) (PieceMap b y) =
|
|
||||||
PieceMap (append a b) (Map.unionWith append x y)
|
|
||||||
-- I'm sure there's some nice type-level trickery we could employ here somehow
|
|
||||||
-- to ensure this never happens.
|
|
||||||
append _ _ = error "Mismatched PieceMaps for append"
|
|
||||||
|
|
||||||
data PieceMap req res = PieceMap
|
|
||||||
{ pmDynamic :: PieceMap req res
|
|
||||||
, pmStatic :: Map.Map Text (PieceMap req res)
|
|
||||||
} | PieceMapEnd [(Int, Dispatch req res)]
|
|
||||||
|
|
||||||
toPieceMap :: Int -> [RouteHandler req res] -> PieceMap req res
|
|
||||||
toPieceMap depth = toPieceMap' depth . zip [1..]
|
|
||||||
|
|
||||||
toPieceMap' :: Int
|
|
||||||
-> [(Int, RouteHandler req res)]
|
|
||||||
-> PieceMap req res
|
|
||||||
toPieceMap' 0 rhs =
|
|
||||||
PieceMapEnd $ map (second rhDispatch)
|
|
||||||
$ sortBy (comparing fst) rhs
|
|
||||||
toPieceMap' depth rhs = PieceMap
|
|
||||||
{ pmDynamic = toPieceMap' depth' dynamics
|
|
||||||
, pmStatic = Map.map (toPieceMap' depth') statics
|
|
||||||
}
|
|
||||||
where
|
|
||||||
depth' = depth - 1
|
|
||||||
|
|
||||||
pairs = map toPair rhs
|
|
||||||
toPair (i, RouteHandler (p:ps) b c) = (p, (i, RouteHandler ps b c))
|
|
||||||
-- if we have no more pieces, that means this is a rhHasMulti, so fill in
|
|
||||||
-- with dynamic
|
|
||||||
toPair (i, RouteHandler [] b c) = (SinglePiece, (i, RouteHandler [] b c))
|
|
||||||
|
|
||||||
getDynamic (SinglePiece, rh) = Just rh
|
|
||||||
getDynamic _ = Nothing
|
|
||||||
dynamics = mapMaybe getDynamic pairs
|
|
||||||
|
|
||||||
getStatic (StaticPiece t, rh) = Just $ Map.singleton t [rh]
|
|
||||||
getStatic _ = Nothing
|
|
||||||
statics = Map.unionsWith (++) $ mapMaybe getStatic pairs
|
|
||||||
|
|
||||||
data ByCount req res = ByCount
|
|
||||||
{ bcVector :: !(V.Vector (PieceMap req res))
|
|
||||||
, bcRest :: !(PieceMap req res)
|
|
||||||
}
|
|
||||||
|
|
||||||
toBC :: [RouteHandler req res] -> ByCount req res
|
|
||||||
toBC rhs =
|
|
||||||
ByCount
|
|
||||||
{ bcVector = V.map (\i -> toPieceMap i $ filter (canHaveLength i) rhs)
|
|
||||||
$ V.enumFromN 0 (maxLen + 1)
|
|
||||||
, bcRest = toPieceMap maxLen $ filter rhHasMulti rhs
|
|
||||||
}
|
|
||||||
where
|
|
||||||
maxLen = maximum $ map (length . rhPieces) rhs
|
|
||||||
|
|
||||||
canHaveLength i rh =
|
|
||||||
len == i || (len < i && rhHasMulti rh)
|
|
||||||
where
|
|
||||||
len = length $ rhPieces rh
|
|
||||||
112
yesod-routes/Yesod/Routes/Dispatch.lhs
Normal file
112
yesod-routes/Yesod/Routes/Dispatch.lhs
Normal file
@ -0,0 +1,112 @@
|
|||||||
|
> module Yesod.Routes.Dispatch
|
||||||
|
> ( Piece (..)
|
||||||
|
> , RouteHandler (..)
|
||||||
|
> , Dispatch
|
||||||
|
> , toDispatch
|
||||||
|
> ) where
|
||||||
|
>
|
||||||
|
> import Data.Text (Text)
|
||||||
|
> import qualified Data.Vector as V
|
||||||
|
> import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
|
> import qualified Data.Map as Map
|
||||||
|
> import Data.List (sortBy)
|
||||||
|
> import Data.Ord (comparing)
|
||||||
|
> import Control.Arrow (second)
|
||||||
|
>
|
||||||
|
> data Piece = StaticPiece Text | SinglePiece
|
||||||
|
> type Dispatch req res = [Text] -> req -> Maybe res
|
||||||
|
>
|
||||||
|
> data RouteHandler req res = RouteHandler
|
||||||
|
> { rhPieces :: [Piece]
|
||||||
|
> , rhHasMulti :: Bool
|
||||||
|
> , rhDispatch :: Dispatch req res
|
||||||
|
> }
|
||||||
|
>
|
||||||
|
> toDispatch :: [RouteHandler req res] -> [Text] -> req -> Maybe res
|
||||||
|
> toDispatch rhs =
|
||||||
|
> bcToDispatch bc
|
||||||
|
> where
|
||||||
|
> bc = toBC rhs
|
||||||
|
>
|
||||||
|
> bcToDispatch :: ByCount req res -> Dispatch req res
|
||||||
|
> bcToDispatch (ByCount vec rest) ts0 req =
|
||||||
|
> bcToDispatch' ts0 pm0
|
||||||
|
> where
|
||||||
|
> --pm0 :: PieceMap sub master res
|
||||||
|
> pm0 = fromMaybe rest $ vec V.!? length ts0
|
||||||
|
>
|
||||||
|
> --bcToDispatch' :: [Text] -> PieceMap req res -> Maybe res
|
||||||
|
> bcToDispatch' _ (PieceMapEnd r) =
|
||||||
|
> firstJust (\f -> f ts0 req) $ map snd $ sortBy (comparing fst) r
|
||||||
|
> bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $
|
||||||
|
> case Map.lookup t sta of
|
||||||
|
> Nothing -> dyn
|
||||||
|
> Just pm -> append dyn pm
|
||||||
|
> bcToDispatch' [] _ = Nothing
|
||||||
|
>
|
||||||
|
> firstJust :: (a -> Maybe b) -> [a] -> Maybe b
|
||||||
|
> firstJust _ [] = Nothing
|
||||||
|
> firstJust f (a:as) = maybe (firstJust f as) Just $ f a
|
||||||
|
>
|
||||||
|
> append :: PieceMap a b -> PieceMap a b -> PieceMap a b
|
||||||
|
> append (PieceMapEnd a) (PieceMapEnd b) = PieceMapEnd $ a ++ b
|
||||||
|
> append (PieceMap a x) (PieceMap b y) =
|
||||||
|
> PieceMap (append a b) (Map.unionWith append x y)
|
||||||
|
> -- I'm sure there's some nice type-level trickery we could employ here somehow
|
||||||
|
> -- to ensure this never happens.
|
||||||
|
> append _ _ = error "Mismatched PieceMaps for append"
|
||||||
|
>
|
||||||
|
> data PieceMap req res = PieceMap
|
||||||
|
> { pmDynamic :: PieceMap req res
|
||||||
|
> , pmStatic :: Map.Map Text (PieceMap req res)
|
||||||
|
> } | PieceMapEnd [(Int, Dispatch req res)]
|
||||||
|
>
|
||||||
|
> toPieceMap :: Int -> [RouteHandler req res] -> PieceMap req res
|
||||||
|
> toPieceMap depth = toPieceMap' depth . zip [1..]
|
||||||
|
>
|
||||||
|
> toPieceMap' :: Int
|
||||||
|
> -> [(Int, RouteHandler req res)]
|
||||||
|
> -> PieceMap req res
|
||||||
|
> toPieceMap' 0 rhs =
|
||||||
|
> PieceMapEnd $ map (second rhDispatch)
|
||||||
|
> $ sortBy (comparing fst) rhs
|
||||||
|
> toPieceMap' depth rhs = PieceMap
|
||||||
|
> { pmDynamic = toPieceMap' depth' dynamics
|
||||||
|
> , pmStatic = Map.map (toPieceMap' depth') statics
|
||||||
|
> }
|
||||||
|
> where
|
||||||
|
> depth' = depth - 1
|
||||||
|
>
|
||||||
|
> pairs = map toPair rhs
|
||||||
|
> toPair (i, RouteHandler (p:ps) b c) = (p, (i, RouteHandler ps b c))
|
||||||
|
> -- if we have no more pieces, that means this is a rhHasMulti, so fill in
|
||||||
|
> -- with dynamic
|
||||||
|
> toPair (i, RouteHandler [] b c) = (SinglePiece, (i, RouteHandler [] b c))
|
||||||
|
>
|
||||||
|
> getDynamic (SinglePiece, rh) = Just rh
|
||||||
|
> getDynamic _ = Nothing
|
||||||
|
> dynamics = mapMaybe getDynamic pairs
|
||||||
|
>
|
||||||
|
> getStatic (StaticPiece t, rh) = Just $ Map.singleton t [rh]
|
||||||
|
> getStatic _ = Nothing
|
||||||
|
> statics = Map.unionsWith (++) $ mapMaybe getStatic pairs
|
||||||
|
>
|
||||||
|
> data ByCount req res = ByCount
|
||||||
|
> { bcVector :: !(V.Vector (PieceMap req res))
|
||||||
|
> , bcRest :: !(PieceMap req res)
|
||||||
|
> }
|
||||||
|
>
|
||||||
|
> toBC :: [RouteHandler req res] -> ByCount req res
|
||||||
|
> toBC rhs =
|
||||||
|
> ByCount
|
||||||
|
> { bcVector = V.map (\i -> toPieceMap i $ filter (canHaveLength i) rhs)
|
||||||
|
> $ V.enumFromN 0 (maxLen + 1)
|
||||||
|
> , bcRest = toPieceMap maxLen $ filter rhHasMulti rhs
|
||||||
|
> }
|
||||||
|
> where
|
||||||
|
> maxLen = maximum $ map (length . rhPieces) rhs
|
||||||
|
>
|
||||||
|
> canHaveLength i rh =
|
||||||
|
> len == i || (len < i && rhHasMulti rh)
|
||||||
|
> where
|
||||||
|
> len = length $ rhPieces rh
|
||||||
@ -3,7 +3,7 @@ import Test.Hspec.Monadic
|
|||||||
import Test.Hspec.HUnit ()
|
import Test.Hspec.HUnit ()
|
||||||
import Test.HUnit ((@?=))
|
import Test.HUnit ((@?=))
|
||||||
import Data.Text (Text, unpack)
|
import Data.Text (Text, unpack)
|
||||||
import Yesod.Routes
|
import Yesod.Routes.Dispatch
|
||||||
|
|
||||||
result :: ([Text] -> Maybe Int) -> Dispatch () Int
|
result :: ([Text] -> Maybe Int) -> Dispatch () Int
|
||||||
result f ts () = f ts
|
result f ts () = f ts
|
||||||
|
|||||||
@ -19,7 +19,7 @@ library
|
|||||||
, clientsession >= 0.7 && < 0.8
|
, clientsession >= 0.7 && < 0.8
|
||||||
, containers >= 0.2 && < 0.5
|
, containers >= 0.2 && < 0.5
|
||||||
|
|
||||||
exposed-modules: Yesod.Routes
|
exposed-modules: Yesod.Routes.Dispatch
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|
||||||
test-suite runtests
|
test-suite runtests
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user