haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move route parsing to yesod-routes

Browse Source
This commit is contained in:
Michael Snoyman 2012-01-05 05:38:31 +02:00
parent 03da3b021a
commit 1e8b15acff
7 changed files with 66 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
yesod-core/Yesod/Dispatch.hs
View File

@ -31,7 +31,7 @@ import Yesod.Handler hiding (lift)
import Yesod.Widget (GWidget)
import Web.PathPieces
import Yesod.Internal.RouteParsing (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
@ -51,7 +51,7 @@ import qualified Blaze.ByteString.Builder
import Network.HTTP.Types (status301)
import Yesod.Routes.TH
import Yesod.Content (chooseRep)
import Yesod.Internal.RouteParsing
import Yesod.Routes.Parse
type Texts = [Text]
@ -59,7 +59,7 @@ type Texts = [Text]
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
-- Use 'parseRoutes' to create the 'Resource's.
mkYesod :: String -- ^ name of the argument datatype
-> RouteString
-> [Resource String]
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
@ -70,7 +70,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-- be embedded in other sites.
mkYesodSub :: String -- ^ name of the argument datatype
-> Cxt
-> RouteString
-> [Resource String]
-> Q [Dec]
mkYesodSub name clazzes =
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
@ -81,28 +81,28 @@ mkYesodSub name clazzes =
-- your handlers elsewhere. For example, this is the only way to break up a
-- monolithic file into smaller parts. Use this function, paired with
-- 'mkYesodDispatch', to do just that.
mkYesodData :: String -> RouteString -> Q [Dec]
mkYesodData :: String -> [Resource String] -> Q [Dec]
mkYesodData name res = mkYesodDataGeneral name [] False res
mkYesodSubData :: String -> Cxt -> RouteString -> Q [Dec]
mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec]
mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
mkYesodDataGeneral :: String -> Cxt -> Bool -> RouteString -> Q [Dec]
mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource String] -> Q [Dec]
mkYesodDataGeneral name clazzes isSub res = do
let (name':rest) = words name
(x, _) <- mkYesodGeneral name' rest clazzes isSub res
let rname = mkName $ "resources" ++ name
eres <- [|parseRouteString $(lift res)|]
eres <- [|fmap parseType $(lift res)|]
let y = [ SigD rname $ ListT `AppT` ConT ''Resource
, FunD rname [Clause [] (NormalB eres) []]
]
return $ x ++ y
-- | See 'mkYesodData'.
mkYesodDispatch :: String -> RouteString -> Q [Dec]
mkYesodDispatch :: String -> [Resource String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
mkYesodSubDispatch :: String -> Cxt -> RouteString -> Q [Dec]
mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec]
mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True
where (name':rest) = words name
@ -110,10 +110,10 @@ mkYesodGeneral :: String -- ^ foundation name
-> [String] -- ^ parameters for foundation
-> Cxt -- ^ classes
-> Bool -- ^ is subsite?
-> RouteString
-> [Resource String]
-> Q ([Dec], [Dec])
mkYesodGeneral name args clazzes isSub resS = do
let res = parseRouteString resS
let res = map (fmap parseType) resS
renderRouteDec <- mkRenderRouteInstance (ConT name') res
disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res

1
yesod-core/yesod-core.cabal
View File

@ -95,7 +95,6 @@ library
Yesod.Internal.Core
Yesod.Internal.Session
Yesod.Internal.Request
Yesod.Internal.RouteParsing
Paths_yesod_core
ghc-options: -Wall

42
yesod-core/Yesod/Internal/RouteParsing.hs → yesod-routes/Yesod/Routes/Parse.hs
View File

@ -1,13 +1,12 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
module Yesod.Internal.RouteParsing
module Yesod.Routes.Parse
( parseRoutes
, parseRoutesFile
, parseRoutesNoCheck
, parseRoutesFileNoCheck
, RouteString
, parseRouteString
, parseType
) where
import Web.PathPieces
@ -33,20 +32,9 @@ parseRoutes = QuasiQuoter
x s = do
let res = resourcesFromString s
case findOverlaps res of
[] -> liftParse s
[] -> lift res
z -> error $ "Overlapping routes: " ++ unlines (map (unwords . map resourceName) z)
newtype RouteString = RouteString String
liftParse :: String -> Q Exp
liftParse s = [|RouteString s|]
parseRouteString :: RouteString -> [Resource]
parseRouteString (RouteString s) = resourcesFromString s
instance Lift RouteString where
lift (RouteString s) = [|RouteString $(lift s)|]
parseRoutesFile :: FilePath -> Q Exp
parseRoutesFile fp = do
s <- qRunIO $ readUtf8File fp
@ -66,13 +54,13 @@ readUtf8File fp = do
-- | Same as 'parseRoutes', but performs no overlap checking.
parseRoutesNoCheck :: QuasiQuoter
parseRoutesNoCheck = QuasiQuoter
{ quoteExp = liftParse
{ quoteExp = lift . resourcesFromString
}
-- | Convert a multi-line string to a set of resources. See documentation for
-- the format of this string. This is a partial function which calls 'error' on
-- invalid input.
resourcesFromString :: String -> [Resource]
resourcesFromString :: String -> [Resource String]
resourcesFromString =
mapMaybe go . lines
where
@ -85,12 +73,12 @@ resourcesFromString =
[] -> Nothing
_ -> error $ "Invalid resource line: " ++ s
dispatchFromString :: [String] -> Maybe Type -> Dispatch
dispatchFromString :: [String] -> Maybe String -> Dispatch String
dispatchFromString rest mmulti
| null rest = Methods mmulti []
| all (all isUpper) rest = Methods mmulti rest
dispatchFromString [subTyp, subFun] Nothing =
Subsite (parseType subTyp) subFun
Subsite subTyp subFun
dispatchFromString [subTyp, subFun] Just{} =
error "Subsites cannot have a multipiece"
dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest
@ -99,7 +87,7 @@ drop1Slash :: String -> String
drop1Slash ('/':x) = x
drop1Slash x = x
piecesFromString :: String -> ([Piece], Maybe Type)
piecesFromString :: String -> ([Piece String], Maybe String)
piecesFromString "" = ([], Nothing)
piecesFromString x =
case (this, rest) of
@ -114,23 +102,23 @@ piecesFromString x =
parseType :: String -> Type
parseType = ConT . mkName -- FIXME handle more complicated stuff
pieceFromString :: String -> Either Type Piece
pieceFromString ('#':x) = Right $ Dynamic $ parseType x
pieceFromString ('*':x) = Left $ parseType x
pieceFromString :: String -> Either String (Piece String)
pieceFromString ('#':x) = Right $ Dynamic x
pieceFromString ('*':x) = Left x
pieceFromString x = Right $ Static x
-- n^2, should be a way to speed it up
findOverlaps :: [Resource] -> [[Resource]]
findOverlaps :: [Resource a] -> [[Resource a]]
findOverlaps = go . map justPieces
where
justPieces :: Resource -> ([Piece], Resource)
justPieces :: Resource a -> ([Piece a], Resource a)
justPieces r@(Resource _ ps _) = (ps, r)
go [] = []
go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
Maybe [Resource]
mOverlap :: ([Piece a], Resource a) -> ([Piece a], Resource a) ->
Maybe [Resource a]
mOverlap _ _ = Nothing
{- FIXME mOverlap
mOverlap (Static x:xs, xr) (Static y:ys, yr)

14
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

@ -67,7 +67,7 @@ import Data.List (foldl')
mkDispatchClause :: Q Exp -- ^ runHandler function
-> Q Exp -- ^ dispatcher function
-> Q Exp -- ^ fixHandler function
-> [Resource]
-> [Resource a]
-> Q Clause
mkDispatchClause runHandler dispatcher fixHandler ress = do
-- Allocate the names to be used. Start off with the names passed to the
@ -120,7 +120,7 @@ methodMapName :: String -> Name
methodMapName s = mkName $ "methods" ++ s
buildMethodMap :: Q Exp -- ^ fixHandler
-> Resource
-> Resource a
-> Q (Maybe Dec)
buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
@ -143,7 +143,7 @@ buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing
-- | Build a single 'D.Route' expression.
buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource -> Q Exp
buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp
buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
-- First two arguments to D.Route
routePieces <- ListE <$> mapM convertPiece resPieces
@ -158,8 +158,8 @@ routeArg3 :: Q Exp -- ^ runHandler
-> Q Exp -- ^ dispatcher
-> Q Exp -- ^ fixHandler
-> String -- ^ name of resource
-> [Piece]
-> Dispatch
-> [Piece a]
-> Dispatch a
-> Q Exp
routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
pieces <- newName "pieces"
@ -224,7 +224,7 @@ buildCaller :: Q Exp -- ^ runHandler
-> Q Exp -- ^ fixHandler
-> Name -- ^ xrest
-> String -- ^ name of resource
-> Dispatch
-> Dispatch a
-> [Name] -- ^ ys
-> Q Exp
buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
@ -290,6 +290,6 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
return $ LamE pat exp
-- | Convert a 'Piece' to a 'D.Piece'
convertPiece :: Piece -> Q Exp
convertPiece :: Piece a -> Q Exp
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|]

6
yesod-routes/Yesod/Routes/TH/RenderRoute.hs
View File

@ -15,7 +15,7 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Yesod.Routes.Class
-- | Generate the constructors of a route data type.
mkRouteCons :: [Resource] -> [Con]
mkRouteCons :: [Resource Type] -> [Con]
mkRouteCons =
map mkRouteCon
where
@ -36,7 +36,7 @@ mkRouteCons =
_ -> []
-- | Clauses for the 'renderRoute' method.
mkRenderRouteClauses :: [Resource] -> Q [Clause]
mkRenderRouteClauses :: [Resource Type] -> Q [Clause]
mkRenderRouteClauses =
mapM go
where
@ -91,7 +91,7 @@ mkRenderRouteClauses =
--
-- This includes both the 'Route' associated type and the 'renderRoute' method.
-- This function uses both 'mkRouteCons' and 'mkRenderRouteClasses'.
mkRenderRouteInstance :: Type -> [Resource] -> Q Dec
mkRenderRouteInstance :: Type -> [Resource Type] -> Q Dec
mkRenderRouteInstance typ ress = do
cls <- mkRenderRouteClauses ress
return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)

73
yesod-routes/Yesod/Routes/TH/Types.hs
View File

@ -10,67 +10,50 @@ module Yesod.Routes.TH.Types
import Language.Haskell.TH.Syntax
liftOccName :: OccName -> Q Exp
liftOccName oc = [|mkOccName $(lift $ occString oc)|]
liftNameFlavour :: NameFlavour -> Q Exp
liftNameFlavour NameS = [|NameS|]
liftName :: Name -> Q Exp
liftName (Name a b) = [|Name $(liftOccName a) $(liftNameFlavour b)|]
liftType :: Type -> Q Exp
liftType (VarT name) = [|VarT $(liftName name)|]
liftType (ConT name) = [|ConT $(liftName name)|]
liftType (TupleT i) = [|TupleT $(lift i)|]
liftType ArrowT = [|ArrowT|]
liftType ListT = [|ListT|]
liftType (AppT a b) = [|AppT $(liftType a) $(liftType b)|]
liftType (SigT a b) = [|SigT $(liftType a) $(liftKind b)|]
liftKind :: Kind -> Q Exp
liftKind StarK = [|StarK|]
liftKind (ArrowK a b) = [|ArrowK $(liftKind a) $(liftKind b)|]
data Resource = Resource
data Resource typ = Resource
{ resourceName :: String
, resourcePieces :: [Piece]
, resourceDispatch :: Dispatch
, resourcePieces :: [Piece typ]
, resourceDispatch :: Dispatch typ
}
deriving Show
{-
instance Lift Resource where
lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]
-}
instance Functor Resource where
fmap f (Resource a b c) = Resource a (map (fmap f) b) (fmap f c)
data Piece = Static String | Dynamic Type
instance Lift t => Lift (Resource t) where
lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]
data Piece typ = Static String | Dynamic typ
deriving Show
{-
instance Lift Piece where
lift (Static s) = [|Static $(lift s)|]
lift (Dynamic t) = [|Static $(liftType t)|]
-}
instance Functor Piece where
fmap _ (Static s) = (Static s)
fmap f (Dynamic t) = Dynamic (f t)
data Dispatch =
instance Lift t => Lift (Piece t) where
lift (Static s) = [|Static $(lift s)|]
lift (Dynamic t) = [|Dynamic $(lift t)|]
data Dispatch typ =
Methods
{ methodsMulti :: Maybe Type -- ^ type of the multi piece at the end
{ methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
, methodsMethods :: [String] -- ^ supported request methods
}
| Subsite
{ subsiteType :: Type
{ subsiteType :: typ
, subsiteFunc :: String
}
deriving Show
{-
instance Lift Dispatch where
lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
lift (Methods (Just t) b) = [|Methods (Just $(liftType t)) $(lift b)|]
lift (Subsite t b) = [|Subsite $(liftType t) $(lift b)|]
-}
instance Functor Dispatch where
fmap f (Methods a b) = Methods (fmap f a) b
fmap f (Subsite a b) = Subsite (f a) b
resourceMulti :: Resource -> Maybe Type
instance Lift t => Lift (Dispatch t) where
lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]
resourceMulti :: Resource typ -> Maybe typ
resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
resourceMulti _ = Nothing

1
yesod-routes/yesod-routes.cabal
View File

@ -22,6 +22,7 @@ library
exposed-modules: Yesod.Routes.Dispatch
Yesod.Routes.TH
Yesod.Routes.Class
Yesod.Routes.Parse
other-modules: Yesod.Routes.TH.Dispatch
Yesod.Routes.TH.RenderRoute
Yesod.Routes.TH.Types