support static page route parsing

yesod-core/Yesod/Dispatch.hs

@@ -14,6 +14,7 @@ module Yesod.Dispatch
     , mkYesodSubData
     , mkYesodDispatch
     , mkYesodSubDispatch
+    , mkYesodStaticPages
       -- ** Path pieces
     , PathPiece (..)
     , PathMultiPiece (..)
@@ -49,9 +50,29 @@ import Network.HTTP.Types (status301)
 import Yesod.Routes.TH
 import Yesod.Content (chooseRep)
 import Yesod.Routes.Parse
+import Data.List (partition)
 
 type Texts = [Text]
 
+mkYesodStaticPages :: String -> [StaticPageRoute] -> Q [Dec]
+mkYesodStaticPages name routes =
+    let (staticGets, staticResources) = partition isGet routes
+        gets = ListE (map (LitE . StringL . toString) staticGets)
+        getsD = ValD (VarP (mkName "staticPageRoutePaths")) (NormalB gets) []
+    in  do yesod <- mkYesod name (map toResource staticResources)
+           return $ [getsD] ++ yesod
+
+  where
+    isGet (StaticGet _)      = True
+    isGet (StaticResource _) = False
+    toResource (StaticResource r) = r
+    toResource (StaticGet _) = error "expected resource"
+    toString (StaticGet str) = dropSlashes str
+    toString (StaticResource _) = error "did not expect resource"
+    dropSlashes str | last str == '/' = dropSlashes $ init str
+                    | head str == '/' = dropSlashes $ tail str
+                    | otherwise = str
+
 -- | Generates URL datatype and site function for the given 'Resource's. This
 -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
 -- Use 'parseRoutes' to create the 'Resource's.

yesod-core/test/YesodCoreTest.hs

@@ -10,6 +10,7 @@ import YesodCoreTest.InternalRequest
 import YesodCoreTest.ErrorHandling
 import YesodCoreTest.Cache
 import qualified YesodCoreTest.Redirect as Redirect
+import qualified YesodCoreTest.StaticPages as StaticPages
 
 import Test.Hspec
 
@@ -25,4 +26,5 @@ specs =
     , errorHandlingTest
     , cacheTest
     , Redirect.specs
+    , StaticPages.specs
     ]

yesod-core/test/YesodCoreTest/StaticPages.hs

@@ -0,0 +1,33 @@
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module YesodCoreTest.StaticPages (specs) where
+
+import Test.Hspec
+import Test.Hspec.HUnit ()
+import Test.HUnit
+
+import Yesod.Core
+import Yesod.Routes.Parse (staticPageRoutes)
+
+data StaticPages = StaticPages
+
+mkYesodStaticPages "StaticPages" [staticPageRoutes|
+/pages/   PageR
+/pages/
+       about
+       data
+       faq
+|]
+
+instance Yesod StaticPages where approot _ = ""
+
+handlePageR :: Handler RepHtml
+handlePageR = defaultLayout [whamlet|Hello World!|]
+
+specs :: [Spec]
+specs = describe "staticPageRoutePaths" [
+    it "lists static page routes" $
+      ["pages","pages/about","pages/data","pages/faq"] @=? staticPageRoutePaths
+  ]

yesod-core/yesod-core.cabal

@@ -127,6 +127,7 @@ test-suite tests
                   , random
                   ,HUnit
                   ,QuickCheck >= 2 && < 3
+                  , yesod-routes          >= 0.0      && < 0.1
     ghc-options:     -Wall
 
 source-repository head

yesod-routes/Yesod/Routes/Parse.hs

@@ -7,11 +7,15 @@ module Yesod.Routes.Parse
     , parseRoutesNoCheck
     , parseRoutesFileNoCheck
     , parseType
+    , staticPageRoutes
+    , staticPageRoutesFile
+    , StaticPageRoute (..)
     ) where
 
 import Language.Haskell.TH.Syntax
 import Data.Maybe
-import Data.Char (isUpper)
+import Data.Char (isUpper, isSpace)
+import Data.List (intercalate)
 import Language.Haskell.TH.Quote
 import qualified System.IO as SIO
 import Yesod.Routes.TH
@@ -49,24 +53,82 @@ readUtf8File fp = do
 -- | Same as 'parseRoutes', but performs no overlap checking.
 parseRoutesNoCheck :: QuasiQuoter
 parseRoutesNoCheck = QuasiQuoter
-    { quoteExp = lift . resourcesFromString
-    }
+    { quoteExp = lift . resourcesFromString }
+
+-- | QuasiQuoter for 'staticPageRoutesFromString'
+staticPageRoutes :: QuasiQuoter
+staticPageRoutes = QuasiQuoter
+    { quoteExp = lift . staticPageRoutesFromString }
+
+-- | parse a file with 'staticPageRoutesFromString'
+staticPageRoutesFile :: FilePath -> Q Exp
+staticPageRoutesFile fp = do
+    s <- qRunIO $ readUtf8File fp
+    quoteExp staticPageRoutes s
+
+data StaticPageRoute = StaticGet String | StaticResource (Resource String)
+instance Lift StaticPageRoute where
+    lift (StaticGet str)    = [|StaticGet $(lift str)|]
+    lift (StaticResource r) = [|StaticResource $(lift r)|]
+
+-- | Convert a multi-line string to a set of routes.
+-- like normal route parsing, but there are just route paths, no route constructors
+-- This is a partial function which calls 'error' on invalid input.
+staticPageRoutesFromString :: String -> [StaticPageRoute]
+staticPageRoutesFromString = parseRoutesFromString staticPageRoute
+  where
+    staticPageRoute r [] = Just (StaticGet r)
+    staticPageRoute r rest = fmap StaticResource $ resourceFromLine r rest
 
 -- | 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 String]
 resourcesFromString =
-    mapMaybe go . lines
+    parseRoutesFromString justResourceFromLine
+
+resourceFromLine :: String -> [String] -> Maybe (Resource String)
+resourceFromLine fullRoute (constr:rest) =
+            let (pieces, mmulti) = piecesFromString $ drop1Slash fullRoute
+                disp = dispatchFromString rest mmulti
+             in Just $ Resource constr pieces disp
+resourceFromLine _ [] = Nothing -- an indenter: there should be indented routes afterwards
+
+  
+justResourceFromLine :: String -> [String] -> Maybe (Resource String)
+justResourceFromLine x xs =
+    case resourceFromLine x xs of
+      Nothing -> error $ "Invalid resource line: " ++ (intercalate " " (x:xs))
+      r -> r
+
+-- | used by 'resourcesFromString' and 'staticPageRoutesFromString'
+parseRoutesFromString :: (String  -- ^ route pattern
+                      -> [String] -- ^ extra
+                      -> Maybe a)
+                      -> String -- ^ unparsed routes
+                      -> [a]
+parseRoutesFromString mkRoute =
+    catMaybes . (parseLines $ error "first route cannot be indented") . lines
   where
-    go s =
-        case takeWhile (/= "--") $ words s of
-            (pattern:constr:rest) ->
-                let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
-                    disp = dispatchFromString rest mmulti
-                 in Just $ Resource constr pieces disp
-            [] -> Nothing
-            _ -> error $ "Invalid resource line: " ++ s
+    indents :: String -> Int
+    indents = length . takeWhile isSpace
+
+    parseLines noIndent (l:ls) =
+        case takeWhile (/= "--") $ words l of
+            (route:rest) ->
+                let (newNoIndent, fullRoute) =
+                        if indents l == 0
+                          -- important: the check is done lazily
+                          then (checkEndSlash route, route)
+                          else (noIndent, noIndent ++ route)
+                 in mkRoute fullRoute rest : parseLines newNoIndent ls
+            [] -> parseLines noIndent ls
+    parseLines _ [] = []
+
+    checkEndSlash route =
+        if last route /= '/'
+            then error "the route indenter was expected to have a slash: " ++ route
+            else route
 
 dispatchFromString :: [String] -> Maybe String -> Dispatch String
 dispatchFromString rest mmulti