From a7cfa5f6675410a771c20eb24df7bed5f63ffa6c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 17 Dec 2009 19:27:03 +0200 Subject: [PATCH] Added two basic examples --- Yesod.hs | 6 ++++++ Yesod/Helpers/Auth.hs | 3 --- Yesod/Helpers/Sitemap.hs | 6 ++++-- Yesod/Resource.hs | 29 +++++++++++++++++------------ Yesod/Yesod.hs | 2 ++ examples/hellotemplate.lhs | 22 ++++++++++++++++++++++ examples/helloworld.lhs | 19 +++++++++++++++++++ examples/template.html | 26 ++++++++++++++++++++++++++ test/quasi-resource.hs | 14 ++++++-------- yesod.cabal | 29 +++++++++++++++++++++++++++++ 10 files changed, 131 insertions(+), 25 deletions(-) create mode 100644 examples/hellotemplate.lhs create mode 100644 examples/helloworld.lhs create mode 100644 examples/template.html diff --git a/Yesod.hs b/Yesod.hs index 124c83d4..6aa47888 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -19,6 +19,9 @@ module Yesod , module Yesod.Definitions , module Yesod.Handler , module Yesod.Resource + , module Data.Object.Html + , module Yesod.Rep + , module Data.Convertible.Text , Application ) where @@ -29,3 +32,6 @@ import Yesod.Definitions import Yesod.Handler import Yesod.Resource import Hack (Application) +import Yesod.Rep +import Data.Object.Html +import Data.Convertible.Text diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 087e65b0..60e3f319 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -26,9 +26,6 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId import Data.Enumerable -import Data.Object.Html -import Data.Convertible.Text - import Yesod import Yesod.Constants diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index e5cc9ab8..bc0694f2 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -86,13 +86,15 @@ instance HasReps SitemapResponse where [ (TypeXml, return . cs) ] -sitemap :: Yesod yesod => IO [SitemapUrl] -> Handler yesod SitemapResponse +sitemap :: YesodApproot yesod + => IO [SitemapUrl] + -> Handler yesod SitemapResponse sitemap urls' = do yesod <- getYesod urls <- liftIO urls' return $ SitemapResponse urls $ approot yesod -robots :: Yesod yesod => Handler yesod Plain +robots :: YesodApproot yesod => Handler yesod Plain robots = do yesod <- getYesod return $ plain $ "Sitemap: " ++ unApproot (approot yesod) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 5b129ada..b92df293 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -38,6 +38,10 @@ import Data.Char (isDigit) import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote +{- Debugging +import Language.Haskell.TH.Ppr +import System.IO +-} import Data.Typeable (Typeable) import Control.Exception (Exception) @@ -263,7 +267,10 @@ instance Exception RepeatedVerb rpnodesTHCheck :: [RPNode] -> Q Exp rpnodesTHCheck nodes = do nodes' <- runIO $ checkRPNodes nodes - -- For debugging purposes runIO $ putStrLn $ pprint res + {- For debugging purposes + rpnodesTH nodes' >>= runIO . putStrLn . pprint + runIO $ hFlush stdout + -} rpnodesTH nodes' notFoundVerb :: Verb -> Handler yesod a @@ -338,11 +345,6 @@ countParams (RP rpps) = helper 0 rpps where helper i (Static _:rest) = helper i rest helper i (_:rest) = helper (i + 1) rest -instance Lift RPNode where - lift (RPNode rp vm) = do - rp' <- lift rp - vm' <- liftVerbMap vm $ countParams rp - return $ TupE [rp', vm'] instance Lift RP where lift (RP rpps) = do rpps' <- lift rpps @@ -365,14 +367,17 @@ liftVerbMap :: VerbMap -> Int -> Q Exp liftVerbMap (AllVerbs s) _ = do cr <- [|(.) (fmap chooseRep)|] return $ cr `AppE` ((VarE $ mkName s) `AppE` (VarE $ mkName "verb")) -liftVerbMap (Verbs vs) params = - return $ CaseE (VarE $ mkName "verb") - $ map helper vs ++ [whenNotFound] +liftVerbMap (Verbs vs) params = do + cr0 <- [|fmap chooseRep|] + cr1 <- [|(.) (fmap chooseRep)|] + let cr = if params == 0 then cr0 else cr1 + return $ CaseE (VarE $ mkName "verb") + $ map (helper cr) vs ++ [whenNotFound] where - helper :: (Verb, String) -> Match - helper (v, f) = + helper :: Exp -> (Verb, String) -> Match + helper cr (v, f) = Match (ConP (mkName $ show v) []) - (NormalB $ VarE $ mkName f) + (NormalB $ cr `AppE` VarE (mkName f)) [] whenNotFound :: Match whenNotFound = diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 048cdad8..6e48385f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,6 +1,7 @@ -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) + , YesodApproot (..) , toHackApp ) where @@ -35,6 +36,7 @@ class Yesod a where errorHandler :: ErrorResult -> Handler a RepChooser errorHandler = defaultErrorHandler +class Yesod a => YesodApproot a where -- | An absolute URL to the root of the application. approot :: a -> Approot diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs new file mode 100644 index 00000000..869f06c6 --- /dev/null +++ b/examples/hellotemplate.lhs @@ -0,0 +1,22 @@ +\begin{code} +{-# LANGUAGE QuasiQuotes #-} + +import Yesod +import Hack.Handler.SimpleServer + +data HelloWorld = HelloWorld +instance Yesod HelloWorld where + handlers = [$resources| +/: + Get: helloWorld +|] + +helloWorld :: Handler HelloWorld TemplateFile +helloWorld = return $ TemplateFile "examples/template.html" $ cs + [ ("title", "Hello world!") + , ("content", "Hey look!! I'm !") + ] + +main :: IO () +main = putStrLn "Running..." >> run 3000 (toHackApp HelloWorld) +\end{code} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs new file mode 100644 index 00000000..de8a90de --- /dev/null +++ b/examples/helloworld.lhs @@ -0,0 +1,19 @@ +\begin{code} +{-# LANGUAGE QuasiQuotes #-} + +import Yesod +import Hack.Handler.SimpleServer + +data HelloWorld = HelloWorld +instance Yesod HelloWorld where + handlers = [$resources| +/: + Get: helloWorld +|] + +helloWorld :: Handler HelloWorld HtmlObject +helloWorld = return $ cs "Hello world!" + +main :: IO () +main = putStrLn "Running..." >> run 3000 (toHackApp HelloWorld) +\end{code} diff --git a/examples/template.html b/examples/template.html new file mode 100644 index 00000000..8d1b393d --- /dev/null +++ b/examples/template.html @@ -0,0 +1,26 @@ + + + + + $o.title$ + + + +
+ $o.content$ +
+ + diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index 4ee87fce..46faac53 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -2,8 +2,6 @@ {-# LANGUAGE QuasiQuotes #-} import Yesod -import Yesod.Rep -import Data.Object.Html data MyYesod = MyYesod @@ -11,18 +9,18 @@ instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" getStatic :: Verb -> [String] -> Handler MyYesod HtmlObject getStatic v p = return $ toHtmlObject ["getStatic", show v, show p] -pageIndex :: Handler MyYesod RepChooser -pageIndex = return $ chooseRep $ toHtmlObject ["pageIndex"] +pageIndex :: Handler MyYesod HtmlObject +pageIndex = return $ toHtmlObject ["pageIndex"] pageAdd :: Handler MyYesod RepChooser pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] pageDetail :: String -> Handler MyYesod RepChooser pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s] -pageDelete :: String -> Handler MyYesod RepChooser -pageDelete s = return $ chooseRep $ toHtmlObject ["pageDelete", s] +pageDelete :: String -> Handler MyYesod HtmlObject +pageDelete s = return $ toHtmlObject ["pageDelete", s] pageUpdate :: String -> Handler MyYesod RepChooser pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] -userInfo :: Int -> Handler MyYesod RepChooser -userInfo i = return $ chooseRep $ toHtmlObject ["userInfo", show i] +userInfo :: Int -> Handler MyYesod HtmlObject +userInfo i = return $ toHtmlObject ["userInfo", show i] instance Show (Verb -> Handler MyYesod RepChooser) where show _ = "verb -> handler" diff --git a/yesod.cabal b/yesod.cabal index 137fa631..be2ebd03 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -16,6 +16,10 @@ flag buildtests description: Build the executable to run unit tests default: False +flag buildsamples + description: Build the executable to run unit tests + default: False + flag nolib description: Skip building of the library. default: False @@ -87,3 +91,28 @@ executable runtests Buildable: False ghc-options: -Wall main-is: runtests.hs + +executable quasi-test + if flag(buildsamples) + Buildable: True + else + Buildable: False + ghc-options: -Wall + main-is: test/quasi-resource.hs + +executable helloworld + if flag(buildsamples) + Buildable: True + else + Buildable: False + ghc-options: -Wall + build-depends: hack-handler-simpleserver >= 0.2.0 && < 0.3 + main-is: examples/helloworld.lhs + +executable hellotemplate + if flag(buildsamples) + Buildable: True + else + Buildable: False + ghc-options: -Wall + main-is: examples/hellotemplate.lhs