Removed Data.Object.Html and Yesod.Template

Data/Object/Html.hs

@@ -1,252 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
--- | An 'Html' data type and associated 'ConvertSuccess' instances. This has
--- useful conversions in web development:
---
--- * Automatic generation of simple HTML documents from 'HtmlObject' (mostly
--- useful for testing, you would never want to actually show them to an end
--- user).
---
--- * Converts to JSON, which gives fully HTML escaped JSON. Very nice for Ajax.
---
--- * Can be used with HStringTemplate.
-module Data.Object.Html
-    ( -- * Data type
-      Html (..)
-    , HtmlDoc (..)
-    , HtmlFragment (..)
-    , HtmlObject
-      -- * XML helpers
-    , XmlDoc (..)
-    , cdata
-      -- * Standard 'Object' functions
-    , toHtmlObject
-    , fromHtmlObject
-     -- * Re-export
-    , module Data.Object
-#if TEST
-    , testSuite
-#endif
-    ) where
-
-import Data.Generics
-import Data.Object.Text
-import Data.Object.String
-import Data.Object.Json
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text as TS
-import Web.Encodings
-import Text.StringTemplate.Classes
-import Control.Arrow (second)
-import Data.Attempt
-import Data.Object
-
-#if TEST
-import Test.Framework (testGroup, Test)
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
-import Text.StringTemplate
-#endif
-
--- | A single piece of HTML code.
-data Html =
-    Html TS.Text -- ^ Already encoded HTML.
-  | Text TS.Text -- ^ Text which should be HTML escaped.
-  | Tag String [(String, String)] Html -- ^ Tag which needs a closing tag.
-  | EmptyTag String [(String, String)] -- ^ Tag without a closing tag.
-  | HtmlList [Html]
-    deriving (Eq, Show, Typeable)
-
--- | A full HTML document.
-newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text }
-
-type HtmlObject = Object String Html
-
-instance ConvertSuccess Html HtmlObject where
-    convertSuccess = Scalar
-instance ConvertSuccess [Html] HtmlObject where
-    convertSuccess = Sequence . map cs
-instance ConvertSuccess [HtmlObject] HtmlObject where
-    convertSuccess = Sequence
-instance ConvertSuccess [(String, HtmlObject)] HtmlObject where
-    convertSuccess = Mapping
-instance ConvertSuccess [(String, Html)] HtmlObject where
-    convertSuccess = Mapping . map (second cs)
-instance ConvertSuccess StringObject HtmlObject where
-    convertSuccess = mapKeysValues cs cs
-
-toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject
-toHtmlObject = cs
-
-fromHtmlObject :: ConvertAttempt HtmlObject x => HtmlObject -> Attempt x
-fromHtmlObject = ca
-
-instance ConvertSuccess String Html where
-    convertSuccess = Text . cs
-instance ConvertSuccess TS.Text Html where
-    convertSuccess = Text
-instance ConvertSuccess Text Html where
-    convertSuccess = Text . cs
-
-instance ConvertSuccess String HtmlObject where
-    convertSuccess = Scalar . cs
-instance ConvertSuccess Text HtmlObject where
-    convertSuccess = Scalar . cs
-instance ConvertSuccess TS.Text HtmlObject where
-    convertSuccess = Scalar . cs
-instance ConvertSuccess [String] HtmlObject where
-    convertSuccess = Sequence . map cs
-instance ConvertSuccess [Text] HtmlObject where
-    convertSuccess = Sequence . map cs
-instance ConvertSuccess [TS.Text] HtmlObject where
-    convertSuccess = Sequence . map cs
-instance ConvertSuccess [(String, String)] HtmlObject where
-    convertSuccess = omTO
-instance ConvertSuccess [(Text, Text)] HtmlObject where
-    convertSuccess = omTO
-instance ConvertSuccess [(TS.Text, TS.Text)] HtmlObject where
-    convertSuccess = omTO
-
-showAttribs :: [(String, String)] -> String -> String
-showAttribs pairs rest = foldr (($) . helper) rest pairs where
-    helper :: (String, String) -> String -> String
-    helper (k, v) rest' =
-        ' ' : encodeHtml k
-        ++ '=' : '"' : encodeHtml v
-        ++ '"' : rest'
-
-htmlToText :: Bool -- ^ True to close empty tags like XML, False like HTML
-           -> Html
-           -> ([TS.Text] -> [TS.Text])
-htmlToText _ (Html t) = (:) t
-htmlToText _ (Text t) = (:) $ encodeHtml t
-htmlToText xml (Tag n as content) = \rest ->
-    cs ('<' : n)
-    : cs (showAttribs as ">")
-    : htmlToText xml content
-    ( cs ('<' : '/' : n)
-    : cs ">"
-    : rest)
-htmlToText xml (EmptyTag n as) = \rest ->
-    cs ('<' : n )
-    : cs (showAttribs as (if xml then "/>" else ">"))
-    : rest
-htmlToText xml (HtmlList l) = flip (foldr ($)) (map (htmlToText xml) l)
-
-newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text }
-instance ConvertSuccess Html HtmlFragment where
-    convertSuccess h = HtmlFragment . TL.fromChunks . htmlToText False h $ []
-instance ConvertSuccess HtmlFragment Html where
-    convertSuccess = HtmlList . map Html . TL.toChunks . unHtmlFragment
--- | Not fully typesafe. You must make sure that when converting to this, the
--- 'Html' starts with a tag.
-newtype XmlDoc = XmlDoc { unXmlDoc :: Text }
-instance ConvertSuccess Html XmlDoc where
-    convertSuccess h = XmlDoc $ TL.fromChunks $
-        cs "<?xml version='1.0' encoding='utf-8' ?>\n"
-        : htmlToText True h []
-
--- | Wrap an 'Html' in CDATA for XML output.
-cdata :: Html -> Html
-cdata h = HtmlList
-    [ Html $ cs "<![CDATA["
-    , h
-    , Html $ cs "]]>"
-    ]
-
-instance ConvertSuccess (Html, Html) HtmlDoc where
-    convertSuccess (h, b) = HtmlDoc $ TL.fromChunks $
-        cs "<!DOCTYPE html>\n"
-        : htmlToText False (Tag "html" [] $ HtmlList
-            [ Tag "head" [] h
-            , Tag "body" [] b
-            ]
-        ) []
-instance ConvertSuccess (Html, HtmlObject) HtmlDoc where
-    convertSuccess (x, y) = cs (x, cs y :: Html)
-instance ConvertSuccess (Html, HtmlObject) JsonDoc where
-    convertSuccess (_, y) = cs y
-
-instance ConvertSuccess HtmlObject Html where
-    convertSuccess (Scalar h) = h
-    convertSuccess (Sequence hs) = Tag "ul" [] $ HtmlList $ map addLi hs
-      where
-        addLi = Tag "li" [] . cs
-    convertSuccess (Mapping pairs) =
-        Tag "dl" [] $ HtmlList $ concatMap addDtDd pairs where
-            addDtDd (k, v) =
-                [ Tag "dt" [] $ Text $ cs k
-                , Tag "dd" [] $ cs v
-                ]
-
-instance ConvertSuccess Html JsonScalar where
-    convertSuccess = cs . unHtmlFragment . cs
-instance ConvertAttempt Html JsonScalar where
-    convertAttempt = return . cs
-
-instance ConvertSuccess HtmlObject JsonObject where
-    convertSuccess = mapKeysValues convertSuccess convertSuccess
-instance ConvertAttempt HtmlObject JsonObject where
-    convertAttempt = return . cs
-
-instance ConvertSuccess HtmlObject JsonDoc where
-    convertSuccess = cs . (cs :: HtmlObject -> JsonObject)
-instance ConvertAttempt HtmlObject JsonDoc where
-    convertAttempt = return . cs
-
-instance ToSElem HtmlObject where
-    toSElem (Scalar h) = STR $ TL.unpack $ unHtmlFragment $ cs h
-    toSElem (Sequence hs) = LI $ map toSElem hs
-    toSElem (Mapping pairs) = helper $ map (second toSElem) pairs where
-        helper :: [(String, SElem b)] -> SElem b
-        helper = SM . cs
-
-#if TEST
-caseHtmlToText :: Assertion
-caseHtmlToText = do
-    let actual = Tag "div" [("id", "foo"), ("class", "bar")] $ HtmlList
-            [ Html $ cs "<br>Some HTML<br>"
-            , Text $ cs "<'this should be escaped'>"
-            , EmptyTag "img" [("src", "baz&")]
-            ]
-    let expected =
-            "<div id=\"foo\" class=\"bar\"><br>Some HTML<br>" ++
-            "&lt;&#39;this should be escaped&#39;&gt;" ++
-            "<img src=\"baz&amp;\"></div>"
-    unHtmlFragment (cs actual) @?= (cs expected :: Text)
-
-caseStringTemplate :: Assertion
-caseStringTemplate = do
-    let content = Mapping
-            [ ("foo", Sequence [ Scalar $ Html $ cs "<br>"
-                               , Scalar $ Text $ cs "<hr>"])
-            , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")])
-            ]
-    let temp = newSTMP "foo:$o.foo$,bar:$o.bar$"
-    let expected = "foo:<br>&lt;hr&gt;,bar:<img src=\"file.jpg\">"
-    expected @=? toString (setAttribute "o" content temp)
-
-caseJson :: Assertion
-caseJson = do
-    let content = Mapping
-            [ ("foo", Sequence [ Scalar $ Html $ cs "<br>"
-                               , Scalar $ Text $ cs "<hr>"])
-            , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")])
-            ]
-    let expected = "{\"bar\":\"<img src=\\\"file.jpg\\\">\"" ++
-                   ",\"foo\":[\"<br>\",\"&lt;hr&gt;\"]" ++
-                   "}"
-    JsonDoc (cs expected) @=? cs content
-
-testSuite :: Test
-testSuite = testGroup "Data.Object.Html"
-    [ testCase "caseHtmlToText" caseHtmlToText
-    , testCase "caseStringTemplate" caseStringTemplate
-    , testCase "caseJson" caseJson
-    ]
-
-#endif

Yesod.hs

@@ -21,23 +21,21 @@ module Yesod
     , module Yesod.Handler
     , module Yesod.Resource
     , module Yesod.Form
-    , module Data.Object.Html
-    , module Yesod.Template
     , module Web.Mime
+    , module Yesod.Hamlet
     , Application
     , Method (..)
+    , cs
     ) where
 
 #if TEST
 import Yesod.Resource hiding (testSuite)
 import Yesod.Response hiding (testSuite)
-import Data.Object.Html hiding (testSuite)
 import Yesod.Request hiding (testSuite)
 import Web.Mime hiding (testSuite)
 #else
 import Yesod.Resource
 import Yesod.Response
-import Data.Object.Html
 import Yesod.Request
 import Web.Mime
 #endif
@@ -47,4 +45,5 @@ import Yesod.Yesod
 import Yesod.Definitions
 import Yesod.Handler
 import Network.Wai (Application, Method (..))
-import Yesod.Template
+import Yesod.Hamlet
+import Data.Convertible.Text (cs)

Yesod/Hamlet.hs

@@ -1,11 +1,16 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Hamlet
     ( hamletToContent
     , hamletToRepHtml
     , PageContent (..)
     , Hamlet
     , hamlet
-    , simpleContent
     , HtmlContent (..)
+    , HtmlObject
     )
     where
 
@@ -13,8 +18,8 @@ import Text.Hamlet
 import Text.Hamlet.Monad (outputHtml)
 import Yesod.Response
 import Yesod.Handler
-import Data.Text (pack)
+import Data.Convertible.Text
-import Data.Convertible.Text (cs)
+import Data.Object
 
 data PageContent url = PageContent
     { pageTitle :: IO HtmlContent
@@ -22,13 +27,6 @@ data PageContent url = PageContent
     , pageBody :: Hamlet url IO ()
     }
 
-simpleContent :: String -> HtmlContent -> PageContent url
-simpleContent title body = PageContent
-    { pageTitle = return $ Unencoded $ pack title
-    , pageHead = return ()
-    , pageBody = outputHtml body
-    }
-
 hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content
 hamletToContent h = do
     render <- getUrlRender
@@ -45,3 +43,33 @@ hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml
 hamletToRepHtml h = do
     c <- hamletToContent h
     return $ RepHtml c
+
+instance Monad m => ConvertSuccess String (Hamlet url m ()) where
+    convertSuccess = outputHtml . Unencoded . cs
+instance Monad m
+    => ConvertSuccess (Object String HtmlContent) (Hamlet url m ()) where
+    convertSuccess (Scalar h) = outputHtml h
+    convertSuccess (Sequence s) = template () where
+        template = [$hamlet|
+                %ul
+                    $forall s' s
+                        %li ^s^|]
+        s' _ = return $ fromList $ map cs s
+    convertSuccess (Mapping m) = template () where
+        template :: Monad m => () -> Hamlet url m ()
+        template = [$hamlet|
+                %dl
+                    $forall pairs pair
+                        %dt $pair.key$
+                        %dd ^pair.val^|]
+        pairs _ = return $ fromList $ map go m
+        go (k, v) = Pair (return $ cs k) $ cs v
+instance ConvertSuccess String HtmlContent where
+    convertSuccess = Unencoded . cs
+
+data Pair url m = Pair { key :: m HtmlContent, val :: Hamlet url m () }
+
+type HtmlObject = Object String HtmlContent
+
+instance ConvertSuccess (Object String String) HtmlObject where
+    convertSuccess = fmap cs

Yesod/Handler.hs

@@ -52,10 +52,11 @@ import Control.Monad.Attempt
 import Control.Monad (liftM, ap)
 
 import System.IO
-import Data.Object.Html
 import qualified Data.ByteString.Lazy as BL
 import qualified Network.Wai as W
 
+import Data.Convertible.Text (cs)
+
 type family Routes y
 
 data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String)
@@ -155,8 +156,10 @@ sendFile ct = specialResponse . SendFile ct
 notFound :: Failure ErrorResponse m => m a
 notFound = failure NotFound
 
-badMethod :: Failure ErrorResponse m => m a
+badMethod :: (RequestReader m, Failure ErrorResponse m) => m a
-badMethod = failure BadMethod
+badMethod = do
+    w <- waiRequest
+    failure $ BadMethod $ cs $ W.methodToBS $ W.requestMethod w
 
 permissionDenied :: Failure ErrorResponse m => m a
 permissionDenied = failure PermissionDenied

Yesod/Helpers/AtomFeed.hs

@@ -23,7 +23,8 @@ module Yesod.Helpers.AtomFeed
 
 import Yesod
 import Data.Time.Clock (UTCTime)
-import Web.Encodings (formatW3)
+-- FIXME import Web.Encodings (formatW3)
+import Data.Convertible.Text
 
 data AtomFeedResponse = AtomFeedResponse AtomFeed Approot
 
@@ -48,11 +49,12 @@ data AtomFeedEntry = AtomFeedEntry
     { atomEntryLink :: Location
     , atomEntryUpdated :: UTCTime
     , atomEntryTitle :: String
-    , atomEntryContent :: Html
+    , atomEntryContent :: HtmlContent
     }
 
 instance ConvertSuccess AtomFeedResponse Content where
-    convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
+    convertSuccess = error "FIXME" -- cs . (cs :: Html -> XmlDoc) . cs
+{- FIXME
 instance ConvertSuccess AtomFeedResponse Html where
     convertSuccess (AtomFeedResponse f ar) =
         Tag "feed" [("xmlns", "http://www.w3.org/2005/Atom")] $ HtmlList
@@ -75,3 +77,4 @@ instance ConvertSuccess (AtomFeedEntry, Approot) Html where
         , Tag "title" [] $ cs $ atomEntryTitle e
         , Tag "content" [("type", "html")] $ cdata $ atomEntryContent e
         ]
+-}

Yesod/Helpers/Auth.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE QuasiQuotes #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Auth
@@ -30,11 +31,11 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow
 import qualified Web.Authenticate.OpenId as OpenId
 
 import Yesod
+import Data.Convertible.Text
 
 import Control.Monad.Attempt
 import qualified Data.ByteString.Char8 as B8
 
-import Data.Maybe (fromMaybe)
 import qualified Network.Wai as W
 import Data.Typeable (Typeable)
 import Control.Exception (Exception)
@@ -90,11 +91,13 @@ authHandler W.GET ["openid", "complete"] = rc authOpenidComplete
 authHandler _ ["login", "rpxnow"] = rc rpxnowLogin
 authHandler _ _ = notFound
 
-data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
+-- FIXME data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
+{- FIXME
 instance ConvertSuccess OIDFormReq Html where
     convertSuccess (OIDFormReq Nothing _) = cs ""
     convertSuccess (OIDFormReq (Just s) _) =
         Tag "p" [("class", "message")] $ cs s
+-}
 
 data ExpectedSingleParam = ExpectedSingleParam
     deriving (Show, Typeable)
@@ -106,20 +109,21 @@ authOpenidForm = do
     case getParams rr "dest" of
         [] -> return ()
         (x:_) -> addCookie destCookieTimeout destCookieName x
-    let html =
+    let html = template (getParams rr "message")
-         HtmlList
+    simpleApplyLayout "Log in via OpenID" html
-          [ case getParams rr "message" of
+  where
-                [] -> HtmlList []
+    urlForward _ = error "FIXME urlForward"
-                (m:_) -> Tag "p" [("class", "message")] $ cs m
+    hasMessage = return . not . null
-          , Tag "form" [("method", "get"), ("action", "forward/")] $
+    message [] = return $ Encoded $ cs ""
-              HtmlList
+    message (m:_) = return $ Unencoded $ cs m
-                [ Tag "label" [("for", "openid")] $ cs "OpenID: "
+    template = [$hamlet|
-                , EmptyTag "input" [("type", "text"), ("id", "openid"),
+$if hasMessage
-                                    ("name", "openid")]
+    %p.message $message$
-                , EmptyTag "input" [("type", "submit"), ("value", "Login")]
+%form!method=get!action=@urlForward@
-                ]
+    %label!for=openid OpenID: 
-          ]
+    %input#openid!type=text!name=openid
-    applyLayout' "Log in via OpenID" html
+    %input!type=submit!value=Login
+|]
 
 authOpenidForward :: YesodAuth y => Handler y ()
 authOpenidForward = do
@@ -190,12 +194,15 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
 
 authCheck :: Yesod y => Handler y ChooseRep
 authCheck = do
-    ident <- maybeIdentifier
+    _ident <- maybeIdentifier
-    dn <- displayName
+    _dn <- displayName
+    error "FIXME applyLayoutJson"
+    {-
     applyLayoutJson "Authentication Status" $ cs
         [ ("identifier", fromMaybe "" ident)
         , ("displayName", fromMaybe "" dn)
         ]
+    -}
 
 authLogout :: YesodAuth y => Handler y ()
 authLogout = do

Yesod/Helpers/Sitemap.hs

@@ -24,8 +24,9 @@ module Yesod.Helpers.Sitemap
     ) where
 
 import Yesod
-import Web.Encodings (formatW3)
+--FIXME import Web.Encodings (formatW3)
 import Data.Time (UTCTime)
+import Data.Convertible.Text
 
 data SitemapChangeFreq = Always
                        | Hourly
@@ -42,8 +43,10 @@ instance ConvertSuccess SitemapChangeFreq String where
     convertSuccess Monthly = "monthly"
     convertSuccess Yearly  = "yearly"
     convertSuccess Never   = "never"
+{- FIXME
 instance ConvertSuccess SitemapChangeFreq Html where
     convertSuccess = (cs :: String -> Html) . cs
+-}
 
 data SitemapUrl = SitemapUrl
     { sitemapLoc :: Location
@@ -53,7 +56,8 @@ data SitemapUrl = SitemapUrl
     }
 data SitemapResponse = SitemapResponse [SitemapUrl] Approot
 instance ConvertSuccess SitemapResponse Content where
-    convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
+    convertSuccess = error "FIXME" -- cs . (cs :: Html -> XmlDoc) . cs
+{- FIXME
 instance ConvertSuccess SitemapResponse Html where
     convertSuccess (SitemapResponse urls ar) =
         Tag "urlset" [("xmlns", sitemapNS)] $ HtmlList $ map helper urls
@@ -67,6 +71,7 @@ instance ConvertSuccess SitemapResponse Html where
                     , Tag "changefreq" [] $ cs freq
                     , Tag "priority" [] $ cs $ show pri
                     ]
+-}
 
 instance HasReps SitemapResponse where
     chooseRep = defChooseRep

Yesod/Helpers/Static.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Static

Yesod/Request.hs

@@ -49,6 +49,7 @@ import Control.Arrow ((***))
 import Data.Maybe (fromMaybe)
 import "transformers" Control.Monad.IO.Class
 import Control.Concurrent.MVar
+import Control.Monad (liftM)
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -60,7 +61,7 @@ type ParamName = String
 type ParamValue = String
 type ParamError = String
 
-class RequestReader m where
+class Monad m => RequestReader m where
     getRequest :: m Request
 instance RequestReader ((->) Request) where
     getRequest = id
@@ -69,8 +70,8 @@ languages :: (Functor m, RequestReader m) => m [Language]
 languages = reqLangs `fmap` getRequest
 
 -- | Get the req 'W.Request' value.
-waiRequest :: (Functor m, RequestReader m) => m W.Request
+waiRequest :: RequestReader m => m W.Request
-waiRequest = reqWaiRequest `fmap` getRequest
+waiRequest = reqWaiRequest `liftM` getRequest
 
 type RequestBodyContents =
     ( [(ParamName, ParamValue)]

Yesod/Response.hs

@@ -25,7 +25,6 @@ module Yesod.Response
     , HasReps (..)
     , defChooseRep
     , ioTextToContent
-    , hoToJsonContent
       -- ** Convenience wrappers
     , staticRep
       -- ** Specific content types
@@ -59,7 +58,7 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 import Data.Text.Lazy (Text)
 import qualified Data.Text as T
-import Data.Object.Json
+import Data.Convertible.Text
 
 import Web.Encodings (formatW3)
 import qualified Network.Wai as W
@@ -67,11 +66,9 @@ import qualified Network.Wai.Enumerator as WE
 
 #if TEST
 import Yesod.Request hiding (testSuite)
-import Data.Object.Html hiding (testSuite)
 import Web.Mime hiding (testSuite)
 #else
 import Yesod.Request
-import Data.Object.Html
 import Web.Mime
 #endif
 
@@ -95,10 +92,6 @@ instance ConvertSuccess Text Content where
     convertSuccess lt = cs (cs lt :: L.ByteString)
 instance ConvertSuccess String Content where
     convertSuccess s = cs (cs s :: Text)
-instance ConvertSuccess HtmlDoc Content where
-    convertSuccess = cs . unHtmlDoc
-instance ConvertSuccess XmlDoc Content where
-    convertSuccess = cs . unXmlDoc
 
 type ChooseRep = [ContentType] -> IO (ContentType, Content)
 
@@ -110,9 +103,6 @@ ioTextToContent = swapEnum . WE.fromLBS' . fmap cs
 swapEnum :: W.Enumerator -> Content
 swapEnum (W.Enumerator e) = ContentEnum e
 
-hoToJsonContent :: HtmlObject -> Content
-hoToJsonContent = cs . unJsonDoc . cs
-
 -- | Any type which can be converted to representations.
 class HasReps a where
     chooseRep :: a -> ChooseRep
@@ -148,12 +138,6 @@ instance HasReps [(ContentType, Content)] where
                     (x:_) -> x
                     _ -> error "chooseRep [(ContentType, Content)] of empty"
 
-instance HasReps (Html, HtmlObject) where
-    chooseRep = defChooseRep
-        [ (TypeHtml, return . cs . unHtmlDoc . cs)
-        , (TypeJson, return . cs . unJsonDoc . cs)
-        ]
-
 -- | Data with a single representation.
 staticRep :: ConvertSuccess x Content
           => ContentType
@@ -201,7 +185,7 @@ data ErrorResponse =
     | InternalError String
     | InvalidArgs [(ParamName, ParamError)]
     | PermissionDenied
-    | BadMethod
+    | BadMethod String
     deriving (Show, Eq)
 
 getStatus :: ErrorResponse -> W.Status
@@ -209,6 +193,7 @@ getStatus NotFound = W.Status404
 getStatus (InternalError _) = W.Status500
 getStatus (InvalidArgs _) = W.Status400
 getStatus PermissionDenied = W.Status403
+getStatus (BadMethod _) = W.Status405
 
 ----- header stuff
 -- | Headers to be added to a 'Result'.

Yesod/Template.hs

@@ -1,113 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Yesod.Template
-    ( YesodTemplate (..)
-    , NoSuchTemplate
-    , Template
-    , TemplateGroup
-    , loadTemplateGroup
-    , defaultApplyLayout
-      -- * HTML templates
-    , HtmlTemplate (..)
-    , templateHtml
-    , templateHtmlJson
-    , setHtmlAttrib
-    ) where
-
-import Data.Object.Html
-import Data.Typeable (Typeable)
-import Control.Exception (Exception)
-import Data.Object.Text (Text)
-import Text.StringTemplate
-import Yesod.Response
-import Yesod.Yesod
-import Yesod.Handler
-import Control.Monad (join)
-import Yesod.Request (Request, getRequest)
-
-type Template = StringTemplate Text
-type TemplateGroup = STGroup Text
-
-class Yesod y => YesodTemplate y where
-    getTemplateGroup :: y -> TemplateGroup
-    defaultTemplateAttribs :: y -> Request -> HtmlTemplate
-                           -> IO HtmlTemplate
-    defaultTemplateAttribs _ _ = return
-
-getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup
-getTemplateGroup' = getTemplateGroup `fmap` getYesod
-
-newtype NoSuchTemplate = NoSuchTemplate String
-    deriving (Show, Typeable)
-instance Exception NoSuchTemplate
-
-loadTemplateGroup :: FilePath -> IO TemplateGroup
-loadTemplateGroup = directoryGroupRecursiveLazy
-
-defaultApplyLayout :: YesodTemplate y
-                   => y
-                   -> Request
-                   -> String -- ^ title
-                   -> Html -- ^ body
-                   -> Content
-defaultApplyLayout y req t b =
-    case getStringTemplate "layout" $ getTemplateGroup y of
-        Nothing -> cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc)
-        Just temp ->
-                 ioTextToContent
-               $ fmap (render . unHtmlTemplate)
-               $ defaultTemplateAttribs y req
-               $ setHtmlAttrib "title" t
-               $ setHtmlAttrib "content" b
-               $ HtmlTemplate temp
-
-type TemplateName = String
-newtype HtmlTemplate = HtmlTemplate { unHtmlTemplate :: Template }
-
--- | Return a result using a template generating HTML alone.
-templateHtml :: YesodTemplate y
-             => TemplateName
-             -> (HtmlTemplate -> IO HtmlTemplate)
-             -> Handler y RepHtml
-templateHtml tn f = do
-    tg <- getTemplateGroup'
-    y <- getYesod
-    t <- case getStringTemplate tn tg of
-            Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn
-            Just x -> return x
-    rr <- getRequest
-    return $ RepHtml $ ioTextToContent
-                     $ fmap (render . unHtmlTemplate)
-                     $ join
-                     $ fmap f
-                     $ defaultTemplateAttribs y rr
-                     $ HtmlTemplate t
-
-setHtmlAttrib :: ConvertSuccess x HtmlObject
-              => String -> x -> HtmlTemplate -> HtmlTemplate
-setHtmlAttrib k v (HtmlTemplate t) =
-    HtmlTemplate $ setAttribute k (toHtmlObject v) t
-
--- | Return a result using a template and 'HtmlObject' generating either HTML
--- or JSON output.
-templateHtmlJson :: YesodTemplate y
-                 => TemplateName
-                 -> HtmlObject
-                 -> (HtmlObject -> HtmlTemplate -> IO HtmlTemplate)
-                 -> Handler y RepHtmlJson
-templateHtmlJson tn ho f = do
-    tg <- getTemplateGroup'
-    y <- getYesod
-    rr <- getRequest
-    t <- case getStringTemplate tn tg of
-            Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn
-            Just x -> return x
-    return $ RepHtmlJson
-            ( ioTextToContent
-            $ fmap (render . unHtmlTemplate)
-            $ join
-            $ fmap (f ho)
-            $ defaultTemplateAttribs y rr
-            $ HtmlTemplate t
-            )
-            (hoToJsonContent ho)

Yesod/Yesod.hs

@@ -3,15 +3,12 @@
 module Yesod.Yesod
     ( Yesod (..)
     , YesodSite (..)
-    , applyLayout'
+    , simpleApplyLayout
-    , applyLayoutJson
     , getApproot
     , toWaiApp
     , basicHandler
     ) where
 
-import Data.Object.Html
-import Data.Object.Json (unJsonDoc)
 import Yesod.Response
 import Yesod.Request
 import Yesod.Definitions
@@ -19,6 +16,8 @@ import Yesod.Hamlet
 import Yesod.Handler hiding (badMethod)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as B8
+import Data.Convertible.Text
+import Text.Hamlet.Monad (fromList)
 
 import Data.Maybe (fromMaybe)
 import Web.Mime
@@ -54,7 +53,7 @@ class YesodSite a => Yesod a where
     errorHandler :: Yesod y => a -> ErrorResponse -> Handler y ChooseRep
     errorHandler _ = defaultErrorHandler
 
-    -- | Applies some form of layout to <title> and <body> contents of a page.
+    -- | Applies some form of layout to <title> and <body> contents of a page. FIXME: use a Maybe here to allow subsites to simply inherit.
     applyLayout :: a
                 -> PageContent (Routes a)
                 -> Request
@@ -77,13 +76,17 @@ class YesodSite a => Yesod a where
     -- trailing slash.
     approot :: a -> Approot
 
--- | A convenience wrapper around 'applyLayout'.
+-- | A convenience wrapper around 'simpleApplyLayout for HTML-only data.
-applyLayout' :: Yesod y
+simpleApplyLayout :: Yesod y
-             => String
+                  => String -- ^ title
-             -> Html
+                  -> Hamlet (Routes y) IO () -- ^ body
-             -> Handler y ChooseRep
+                  -> Handler y ChooseRep
-applyLayout' t b = do
+simpleApplyLayout t b = do
-    let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment $ cs b
+    let pc = PageContent
+                { pageTitle = return $ Unencoded $ cs t
+                , pageHead = return ()
+                , pageBody = b
+                }
     y <- getYesod
     rr <- getRequest
     content <- hamletToContent $ applyLayout y pc rr
@@ -91,55 +94,60 @@ applyLayout' t b = do
         [ (TypeHtml, content)
         ]
 
--- | A convenience wrapper around 'applyLayout' which provides a JSON
--- representation of the body.
-applyLayoutJson :: Yesod y
-                => String
-                -> HtmlObject
-                -> Handler y ChooseRep
-applyLayoutJson t b = do
-    let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment
-           $ cs (cs b :: Html)
-    y <- getYesod
-    rr <- getRequest
-    htmlcontent <- hamletToContent $ applyLayout y pc rr
-    return $ chooseRep
-        [ (TypeHtml, htmlcontent)
-        , (TypeJson, cs $ unJsonDoc $ cs b)
-        ]
-
 getApproot :: Yesod y => Handler y Approot
 getApproot = approot `fmap` getYesod
 
 defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep
 defaultErrorHandler NotFound = do
     r <- waiRequest
-    applyLayout' "Not Found" $ cs $ toHtmlObject
+    simpleApplyLayout "Not Found" $ [$hamlet|
-        [ ("Not found", cs $ W.pathInfo r :: String)
+%h1 Not Found
-        ]
+%p $helper$
+|] r
+  where
+    helper = return . Unencoded . cs . W.pathInfo
 defaultErrorHandler PermissionDenied =
-    applyLayout' "Permission Denied" $ cs "Permission denied"
+    simpleApplyLayout "Permission Denied" $ [$hamlet|
+%h1 Permission denied|] ()
 defaultErrorHandler (InvalidArgs ia) =
-    applyLayout' "Invalid Arguments" $ cs $ toHtmlObject
+    simpleApplyLayout "Invalid Arguments" $ [$hamlet|
-            [ ("errorMsg", toHtmlObject "Invalid arguments")
+%h1 Invalid Arguments
-            , ("messages", toHtmlObject ia)
+%dl
-            ]
+    $forall ias pair
+        %dt $pair.key$
+        %dd $pair.val$
+|] ()
+  where
+    ias _ = return $ fromList $ map go ia
+    go (k, v) = Pair (return $ Unencoded $ cs k)
+                     (return $ Unencoded $ cs v)
 defaultErrorHandler (InternalError e) =
-    applyLayout' "Internal Server Error" $ cs $ toHtmlObject
+    simpleApplyLayout "Internal Server Error" $ [$hamlet|
-        [ ("Internal server error", e)
+%h1 Internal Server Error
-        ]
+%p $message$
-defaultErrorHandler BadMethod =
+|] e
-    applyLayout' "Bad Method" $ cs "Method Not Supported"
+  where
+    message :: String -> IO HtmlContent
+    message = return . Unencoded . cs
+defaultErrorHandler (BadMethod m) =
+    simpleApplyLayout "Bad Method" $ [$hamlet|
+%h1 Method Not Supported
+%p Method "$m'$" not supported
+|] ()
+  where
+    m' _ = return $ Unencoded $ cs m
+
+data Pair m k v = Pair { key :: m k, val :: m v }
 
 toWaiApp :: Yesod y => y -> IO W.Application
 toWaiApp a = do
-    key <- encryptKey a
+    key' <- encryptKey a
     let mins = clientSessionDuration a
     return $ gzip
            $ jsonp
            $ methodOverride
            $ cleanPath
-           $ \thePath -> clientsession encryptedCookies key mins
+           $ \thePath -> clientsession encryptedCookies key' mins
            $ toWaiApp' a thePath
 
 toWaiApp' :: Yesod y
@@ -161,7 +169,8 @@ toWaiApp' y resource session env = do
     print pathSegments
     let ya = case eurl of
                 Left _ -> runHandler (errorHandler y NotFound) y render
-                Right url -> handleSite site render url method badMethod y
+                Right url -> handleSite site render url method
+                                        (badMethod method) y
     let eh er = runHandler (errorHandler y er) y render
     unYesodApp ya eh rr types >>= responseToWaiResponse
 
@@ -187,8 +196,9 @@ basicHandler port app = do
             SS.run port app
         Just _ -> CGI.run app
 
-badMethod :: YesodApp
+badMethod :: String -> YesodApp
-badMethod = YesodApp $ \eh req cts -> unYesodApp (eh BadMethod) eh req cts
+badMethod m = YesodApp $ \eh req cts
+         -> unYesodApp (eh $ BadMethod m) eh req cts
 
 fixSegs :: [String] -> [String]
 fixSegs [] = []

examples/fact.lhs

@@ -79,10 +79,11 @@ data, all with HTML entities escaped properly. These representations include:
 For simplicity here, we don't include a template, though it would be trivial to
 do so (see the hellotemplate example).
 
-> getFactR i = applyLayoutJson "Factorial result" $ cs
+> getFactR :: Integer -> Handler y ChooseRep -- FIXME remove
+> getFactR _i = error "FIXME" {-simpleApplyLayout "Factorial result" $ cs
 >             [ ("input", show i)
 >             , ("result", show $ product [1..fromIntegral i :: Integer])
->             ]
+>             ]-}
 
 I've decided to have a redirect instead of serving the some data in two
 locations. It fits in more properly with the RESTful principal of one name for

examples/hamlet.hs

@@ -4,7 +4,6 @@
 
 import Yesod
 import Network.Wai.Handler.SimpleServer
-import Text.Hamlet
 
 data Ham = Ham
 
@@ -21,7 +20,7 @@ data NextLink m = NextLink { nextLink :: m HamRoutes }
 nl :: Monad m => HamRoutes -> NextLink m
 nl = NextLink . return
 
-template :: Monad m => NextLink (Hamlet HamRoutes m) -> Hamlet HamRoutes m ()
+template :: Monad m => NextLink m -> Hamlet HamRoutes m ()
 template = [$hamlet|
 %a!href=@nextLink@ Next page
 |]

examples/hellotemplate.lhs

@@ -1,36 +0,0 @@
-\begin{code}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-
-import Yesod
-import Network.Wai.Handler.SimpleServer
-
-data HelloWorld = HelloWorld TemplateGroup
-
-mkYesod "HelloWorld" [$parseRoutes|
-/       Home  GET
-/groups Group GET
-|]
-
-instance Yesod HelloWorld where
-    approot _ = "http://localhost:3000"
-instance YesodTemplate HelloWorld where
-    getTemplateGroup (HelloWorld tg) = tg
-    defaultTemplateAttribs _ _ = return
-        . setHtmlAttrib "default" "<DEFAULT>"
-
-getHome :: Handler HelloWorld RepHtml
-getHome = templateHtml "template" $ return
-  . setHtmlAttrib "title" "Hello world!"
-  . setHtmlAttrib "content" "Hey look!! I'm <auto escaped>!"
-
-getGroup :: YesodTemplate y => Handler y RepHtmlJson
-getGroup = templateHtmlJson "real-template" (cs "bar") $ \ho ->
-    return . setHtmlAttrib "foo" ho
-
-main :: IO ()
-main = do
-    putStrLn "Running..."
-    loadTemplateGroup "examples" >>= toWaiApp . HelloWorld >>= run 3000
-\end{code}

examples/helloworld.lhs

@@ -16,7 +16,7 @@ instance Yesod HelloWorld where
     approot _ = "http://localhost:3000"
 
 getHome :: Handler HelloWorld ChooseRep
-getHome = applyLayout' "Hello World" $ cs "Hello world!"
+getHome = simpleApplyLayout "Hello World" $ cs "Hello world!"
 
 main :: IO ()
 main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000

examples/pretty-yaml.hs

@@ -8,35 +8,60 @@ import Network.Wai.Handler.SimpleServer
 import Web.Encodings
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
+import Data.Object.String
 
-data PY = PY TemplateGroup
+data PY = PY
 
 mkYesod "PY" [$parseRoutes|
 / Homepage GET POST
 |]
 
-instance YesodTemplate PY where
-    getTemplateGroup (PY tg) = tg
-    defaultTemplateAttribs _ _ = return
 instance Yesod PY where
     approot _ = "http://localhost:3000"
 
-getHomepage :: Handler PY RepHtml
+template :: Monad m => TempArgs url m -> Hamlet url m ()
-getHomepage = templateHtml "pretty-yaml" return
+template = [$hamlet|
+!!!
+%html
+    %head
+        %meta!charset=utf-8
+        %title Pretty YAML
+    %body
+        %form!method=post!action=.!enctype=multipart/form-data
+            File name:
+            %input!type=file!name=yaml
+            %input!type=submit
+        $if hasYaml
+            %div ^yaml^
+|]
 
-postHomepage :: Handler PY RepHtmlJson
+data TempArgs url m = TempArgs
+    { hasYaml :: m Bool
+    , yaml :: Hamlet url m ()
+    }
+
+getHomepage :: Handler PY RepHtml
+getHomepage = hamletToRepHtml
+            $ template $ TempArgs (return False) (return ())
+
+--FIXMEpostHomepage :: Handler PY RepHtmlJson
+postHomepage :: Handler PY RepHtml
 postHomepage = do
     rr <- getRequest
     (_, files) <- liftIO $ reqRequestBody rr
     fi <- case lookup "yaml" files of
             Nothing -> invalidArgs [("yaml", "Missing input")]
             Just x -> return x
-    to <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi
+    so <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi
+    {-
     let ho' = fmap Text to
     templateHtmlJson "pretty-yaml" ho' $ \ho ->
         return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject)
+    -}
+    let ho = cs (so :: StringObject) :: HtmlObject
+    hamletToRepHtml $ template $ TempArgs (return True) (cs ho)
 
 main :: IO ()
 main = do
     putStrLn "Running..."
-    loadTemplateGroup "examples" >>= toWaiApp . PY >>= run 3000
+    toWaiApp PY >>= run 3000

examples/static.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet
 
 import Yesod
 import Yesod.Helpers.Static

examples/tweedle.lhs

@@ -34,7 +34,7 @@ One of the goals of Yesod is to make it work with the compiler to help you progr
 
 To start with, we need a datatype to represent our program. We'll call this bug tracker "Tweedle", after Dr. Seuss's "Tweedle Beetle Battle" in "Fox in Socks" (my son absolutely loves this book). We'll be putting the complete state of the bug database in an MVar within this variable; in a production setting, you might instead put a database handle.
 
-> data Tweedle = Tweedle Settings (MVar Category) TemplateGroup
+> data Tweedle = Tweedle Settings (MVar Category)
 
 (For now, just ignore the TemplateGroup, its purpose becomes apparent later.)
 
@@ -149,7 +149,7 @@ Note that this will die unless an issues file is present. We could instead check
 >   issuesSO <- decodeFile $ issueFile settings
 >   issues <- fromAttempt $ categoryFromSO issuesSO
 >   missues <- newMVar issues
->   tg <- loadTemplateGroup $ templatesDir settings
+>   tg <- error "FIXME switch to hamlet" -- loadTemplateGroup $ templatesDir settings
 >   return $ Tweedle settings missues tg
 
 And now we're going to write our main function. Yesod is built on top of the Web Application Interface (wai package), so a Yesod application runs on a variety of backends. For our purposes, we're going to use the SimpleServer.

yesod.cabal

@@ -53,7 +53,6 @@ library
                      syb,
                      text >= 0.5 && < 0.8,
                      convertible-text >= 0.2.0 && < 0.3,
-                     HStringTemplate >= 0.6.2 && < 0.7,
                      data-object-json >= 0.0.0 && < 0.1,
                      attempt >= 0.2.1 && < 0.3,
                      template-haskell,
@@ -71,8 +70,6 @@ library
                      Yesod.Handler
                      Yesod.Resource
                      Yesod.Yesod
-                     Yesod.Template
-                     Data.Object.Html
                      Yesod.Helpers.Auth
                      Yesod.Helpers.Static
                      Yesod.Helpers.AtomFeed
@@ -82,7 +79,8 @@ library
 
 executable              yesod
     ghc-options:        -Wall
-    build-depends:      file-embed >= 0.0.3 && < 0.1
+    build-depends:      file-embed >= 0.0.3 && < 0.1,
+                        HStringTemplate >= 0.6.2 && < 0.7
     main-is:            CLI/yesod.hs
 
 executable             runtests
@@ -107,13 +105,13 @@ executable             helloworld
   ghc-options:         -Wall
   main-is:             examples/helloworld.lhs
 
-executable             hellotemplate
+executable             hamlet
   if flag(buildsamples)
     Buildable: True
   else
     Buildable: False
   ghc-options:         -Wall
-  main-is:             examples/hellotemplate.lhs
+  main-is:             examples/hamlet.hs
 
 executable             fact
   if flag(buildsamples)