From 1e8b15acff8ef07c21186c27375ca64d69e5c30a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 5 Jan 2012 05:38:31 +0200 Subject: [PATCH] Move route parsing to yesod-routes --- yesod-core/Yesod/Dispatch.hs | 24 +++--- yesod-core/yesod-core.cabal | 1 - .../Yesod/Routes/Parse.hs | 42 ++++------- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 14 ++-- yesod-routes/Yesod/Routes/TH/RenderRoute.hs | 6 +- yesod-routes/Yesod/Routes/TH/Types.hs | 73 +++++++------------ yesod-routes/yesod-routes.cabal | 1 + 7 files changed, 66 insertions(+), 95 deletions(-) rename yesod-core/Yesod/Internal/RouteParsing.hs => yesod-routes/Yesod/Routes/Parse.hs (79%) diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index 8951b192..a1c8691e 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -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 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 24f445ad..121e3637 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -95,7 +95,6 @@ library Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request - Yesod.Internal.RouteParsing Paths_yesod_core ghc-options: -Wall diff --git a/yesod-core/Yesod/Internal/RouteParsing.hs b/yesod-routes/Yesod/Routes/Parse.hs similarity index 79% rename from yesod-core/Yesod/Internal/RouteParsing.hs rename to yesod-routes/Yesod/Routes/Parse.hs index 4d9a1d39..3440e8a5 100644 --- a/yesod-core/Yesod/Internal/RouteParsing.hs +++ b/yesod-routes/Yesod/Routes/Parse.hs @@ -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) diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index ce483ee1..9563e618 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -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|] diff --git a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs index 17dd6e60..04edc094 100644 --- a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs @@ -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) diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs index 83f55149..54428ab8 100644 --- a/yesod-routes/Yesod/Routes/TH/Types.hs +++ b/yesod-routes/Yesod/Routes/TH/Types.hs @@ -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 diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index 8a76e74e..4b399d59 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -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