Move route parsing to yesod-routes

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

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
 

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
+    , parseType
-    , parseRouteString
     ) 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 :: String -> Either String (Piece String)
-pieceFromString ('#':x) = Right $ Dynamic $ parseType x
+pieceFromString ('#':x) = Right $ Dynamic x
-pieceFromString ('*':x) = Left $ parseType 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) ->
+    mOverlap :: ([Piece a], Resource a) -> ([Piece a], Resource a) ->
-                Maybe [Resource]
+                Maybe [Resource a]
     mOverlap _ _ = Nothing
                 {- FIXME mOverlap
     mOverlap (Static x:xs, xr) (Static y:ys, yr)

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]
+          -> [Piece a]
-          -> Dispatch
+          -> 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|]

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)

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
+data Resource typ = Resource
-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
     { resourceName :: String
-    , resourcePieces :: [Piece]
+    , resourcePieces :: [Piece typ]
-    , resourceDispatch :: Dispatch
+    , resourceDispatch :: Dispatch typ
     }
     deriving Show
 
-{-
+instance Functor Resource where
-instance Lift Resource where
+    fmap f (Resource a b c) = Resource a (map (fmap f) b) (fmap f c)
-    lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift 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 Functor Piece where
-instance Lift Piece where
+    fmap _ (Static s) = (Static s)
-    lift (Static s) = [|Static $(lift s)|]
+    fmap f (Dynamic t) = Dynamic (f t)
-    lift (Dynamic t) = [|Static $(liftType 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 Functor Dispatch where
-instance Lift Dispatch where
+    fmap f (Methods a b) = Methods (fmap f a) b
-    lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
+    fmap f (Subsite a b) = Subsite (f a) b
-    lift (Methods (Just t) b) = [|Methods (Just $(liftType t)) $(lift b)|]
-    lift (Subsite t b) = [|Subsite $(liftType t) $(lift 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

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