Quasi-quoting generates a single function

Yesod/Handler.hs

@@ -42,6 +42,9 @@ import Control.Applicative
 import Control.Monad.Writer
 import Control.Monad.Attempt
 
+import System.IO
+import Data.Object.Html
+
 --import Data.Typeable
 
 ------ Handler monad
@@ -98,11 +101,16 @@ runHandler (Handler handler) eh rr y cts = do
                 HCContent a -> Right a
     case contents' of
         Left e -> do
-            Response _ hs ct c <- runHandler (eh e) eh rr y cts
+            Response _ hs ct c <- runHandler (eh e) specialEh rr y cts
             return $ Response (getStatus e) hs ct c
         Right a -> do
             (ct, c) <- a cts
             return $ Response 200 headers ct c
+
+specialEh :: ErrorResult -> Handler yesod RepChooser
+specialEh er = do
+    liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
+    return $ chooseRep $ toHtmlObject "Internal server error"
 {- FIXME
 class ToHandler a where
     toHandler :: a -> Handler

Yesod/Resource.hs

@@ -57,6 +57,7 @@ import Data.Attempt -- for failure stuff
 import Data.Object.Text
 import Control.Monad ((<=<))
 import Data.Object.Yaml
+import Yesod.Handler
 
 #if TEST
 import Control.Monad (replicateM)
@@ -107,6 +108,11 @@ data CheckPatternReturn =
   | DynamicMatch (String, String)
   | NoMatch
 
+checkPatternBool :: RP -> Resource -> Bool
+checkPatternBool rp r = case checkPattern rp r of
+                            Nothing -> False
+                            _ -> True
+
 checkPattern :: RP -> Resource -> Maybe SMap
 checkPattern = checkPatternPieces . unRP
 
@@ -234,10 +240,30 @@ instance Exception RepeatedVerb
 rpnodesTHCheck :: [RPNode] -> Q Exp
 rpnodesTHCheck nodes = do
     nodes' <- runIO $ checkRPNodes nodes
-    rpnodesTH nodes'
+    res <- rpnodesTH nodes'
+    -- For debugging purposes runIO $ putStrLn $ pprint res
+    return res
+
+notFoundVerb :: Verb -> Handler yesod a
+notFoundVerb _verb = notFound
 
 rpnodesTH :: [RPNode] -> Q Exp
-rpnodesTH = fmap ListE . mapM lift
+rpnodesTH ns = do
+    b <- helper ns
+    nfv <- [|notFoundVerb|]
+    let b' = b ++ [(NormalG $ VarE $ mkName "otherwise", nfv)]
+    return $ LamE [VarP $ mkName "resource"]
+           $ CaseE (TupE []) [Match WildP (GuardedB b') []]
+      where
+        helper :: [RPNode] -> Q [(Guard, Exp)]
+        helper nodes = mapM helper2 nodes
+        helper2 :: RPNode -> Q (Guard, Exp)
+        helper2 (RPNode rp vm) = do
+            rp' <- lift rp
+            cpb <- [|checkPatternBool|]
+            let g = cpb `AppE` rp' `AppE` VarE (mkName "resource")
+            vm' <- lift vm
+            return (NormalG g, vm')
 instance Lift RPNode where
     lift (RPNode rp vm) = do
         rp' <- lift rp
@@ -258,7 +284,8 @@ instance Lift RPP where
         return $ ConE (mkName "Slurp") `AppE` (LitE $ StringL s)
 instance Lift VerbMap where
     lift (AllVerbs s) =
-      return $ LamE [VarP $ mkName "_FIXMEverb"] $ VarE $ mkName s
+      return $ LamE [VarP $ mkName "verb"]
+             $ (VarE $ mkName s) `AppE` (VarE $ mkName "verb")
     lift (Verbs vs) =
       return $ LamE [VarP $ mkName "verb"]
              $ CaseE (VarE $ mkName "verb")

Yesod/Response.hs

@@ -53,6 +53,7 @@ import Data.Generics
 import Control.Exception (Exception)
 
 data Response = Response Int [Header] ContentType Content
+    deriving Show
 
 -- | Abnormal return codes.
 data ErrorResult =
@@ -81,6 +82,7 @@ data Header =
     AddCookie Int String String
     | DeleteCookie String
     | Header String String
+    deriving (Eq, Show)
 
 -- | Convert Header to a key/value pair.
 toPair :: Header -> IO (String, String)

test/quasi-resource.hs

@@ -4,29 +4,32 @@
 
 import Yesod
 import Yesod.Rep
+import Data.Object.Html
 
 data MyYesod = MyYesod
 
 instance Show (Handler MyYesod RepChooser) where show _ = "Another handler"
 
-getStatic :: Handler MyYesod RepChooser
-getStatic = undefined
+getStatic :: Verb -> Handler MyYesod RepChooser
+getStatic v = return $ chooseRep $ toHtmlObject ["getStatic", show v]
 pageIndex :: Handler MyYesod RepChooser
-pageIndex = undefined
+pageIndex = return $ chooseRep $ toHtmlObject ["pageIndex"]
 pageAdd :: Handler MyYesod RepChooser
-pageAdd = undefined
+pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"]
 pageDetail :: Handler MyYesod RepChooser
-pageDetail = undefined
+pageDetail = return $ chooseRep $ toHtmlObject ["pageDetail"]
 pageDelete :: Handler MyYesod RepChooser
-pageDelete = undefined
+pageDelete = return $ chooseRep $ toHtmlObject ["pageDelete"]
 pageUpdate :: Handler MyYesod RepChooser
-pageUpdate = undefined
+pageUpdate = return $ chooseRep $ toHtmlObject ["pageUpdate"]
 userInfo :: Handler MyYesod RepChooser
-userInfo = undefined
+userInfo = return $ chooseRep $ toHtmlObject ["userInfo"]
 
 instance Show (Verb -> Handler MyYesod RepChooser) where
     show _ = "verb -> handler"
-handler :: [(RP, Verb -> Handler MyYesod RepChooser)]
+instance Show (Resource -> Verb -> Handler MyYesod RepChooser) where
+    show _ = "resource -> verb -> handler"
+handler :: Resource -> Verb -> Handler MyYesod RepChooser
 handler = [$rpnodesQuasi|
 /static/*filepath/: getStatic
 /page/:
@@ -40,6 +43,20 @@ handler = [$rpnodesQuasi|
     Get: userInfo
 |]
 
+ph :: Handler MyYesod RepChooser -> IO ()
+ph h = do
+    let eh e = return $ chooseRep $ toHtmlObject $ show e
+        rr = error "No raw request"
+        y = MyYesod
+        cts = [TypeHtml]
+    res <- runHandler h eh rr y cts
+    print res
+
 main :: IO ()
 main = do
-    print handler
+    ph $ handler ["static", "foo", "bar", "baz"] Get
+    ph $ handler ["foo", "bar", "baz"] Get
+    ph $ handler ["page"] Get
+    ph $ handler ["user"] Get
+    ph $ handler ["user", "five"] Get
+    ph $ handler ["user", "5"] Get