haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compile with newest Hamlet

Browse Source
This commit is contained in:
Michael Snoyman 2010-06-08 21:51:55 +03:00
parent 46b6dda084
commit a2d2192b9c
7 changed files with 50 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
Yesod/Contrib/Formable.hs
View File

@ -2,11 +2,11 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Yesod.Contrib.Formable where
import Text.Formlets
import Text.Hamlet
import Text.Hamlet.Monad (htmlContentToByteString)
import Data.Time (Day)
import Control.Applicative
import Control.Applicative.Error
@ -26,31 +26,28 @@ class Fieldable a where
fieldable :: (Functor m, Applicative m, Monad m)
=> String -> Formlet (Hamlet url) m a
pack' :: String -> HtmlContent
pack' = Unencoded . cs
instance Fieldable [Char] where
fieldable label = input' go
where
go name val = [$hamlet|
%tr
%th $pack'.label$
%th $string.label$
%td
%input!type=text!name=$pack'.name$!value=$pack'.val$
%input!type=text!name=$string.name$!value=$string.val$
|]
instance Fieldable HtmlContent where
instance Fieldable Html where
fieldable label =
fmap (Encoded . cs)
fmap preEscapedString
. input' go
. fmap (cs . htmlContentToByteString)
. fmap (cs . renderHtml)
where
go name val = [$hamlet|
%tr
%th $pack'.label$
%th $string.label$
%td
%textarea!name=$pack'.name$
$pack'.val$
%textarea!name=$string.name$
$string.val$
|]
instance Fieldable Day where
@ -58,9 +55,9 @@ instance Fieldable Day where
where
go name val = [$hamlet|
%tr
%th $pack'.label$
%th $string.label$
%td
%input!type=date!name=$pack'.name$!value=$pack'.val$
%input!type=date!name=$string.name$!value=$string.val$
|]
asDay s = maybeRead' s "Invalid day"
@ -72,9 +69,9 @@ instance Fieldable Slug where
where
go name val = [$hamlet|
%tr
%th $pack'.label$
%th $string.label$
%td
%input!type=text!name=$pack'.name$!value=$pack'.val$
%input!type=text!name=$string.name$!value=$string.val$
|]
asSlug [] = Failure ["Slug must be non-empty"]
asSlug x'

17
Yesod/Hamlet.hs
View File

@ -5,10 +5,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Hamlet
( -- * Hamlet library
Hamlet
, hamlet
, HtmlContent (..)
, htmlContentToByteString
module Text.Hamlet
-- * Convert to something displayable
, hamletToContent
, hamletToRepHtml
@ -18,8 +15,6 @@ module Yesod.Hamlet
where
import Text.Hamlet
import Text.Hamlet.Monad ( outputHtml, hamletToByteString
, htmlContentToByteString)
import Yesod.Content
import Yesod.Handler
import Data.Convertible.Text
@ -30,7 +25,7 @@ import Web.Routes.Quasi (Routes)
--
-- > PageContent url -> Hamlet url
data PageContent url = PageContent
{ pageTitle :: HtmlContent
{ pageTitle :: Html
, pageHead :: Hamlet url
, pageBody :: Hamlet url
}
@ -40,13 +35,13 @@ data PageContent url = PageContent
hamletToContent :: Hamlet (Routes master) -> GHandler sub master Content
hamletToContent h = do
render <- getUrlRender
return $ toContent $ hamletToByteString render h
return $ toContent $ renderHamlet render h
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: Hamlet (Routes master) -> GHandler sub master RepHtml
hamletToRepHtml = fmap RepHtml . hamletToContent
instance ConvertSuccess String (Hamlet url) where
convertSuccess = outputHtml . Unencoded . cs
instance ConvertSuccess String HtmlContent where
convertSuccess = Unencoded . cs
convertSuccess = const . string
instance ConvertSuccess String Html where
convertSuccess = string

9
Yesod/Handler.hs
View File

@ -70,7 +70,6 @@ import Yesod.Content
import Yesod.Internal
import Web.Routes.Quasi (Routes)
import Data.List (foldl', intercalate)
import Text.Hamlet.Monad (htmlContentToByteString)
import Control.Exception hiding (Handler, catch)
import qualified Control.Exception as E
@ -326,17 +325,17 @@ msgKey = "_MSG"
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
setMessage :: HtmlContent -> GHandler sub master ()
setMessage = setSession msgKey . cs . htmlContentToByteString
setMessage :: Html -> GHandler sub master ()
setMessage = setSession msgKey . cs . renderHtml
-- | Gets the message in the user's session, if available, and then clears the
-- variable.
--
-- See 'setMessage'.
getMessage :: GHandler sub master (Maybe HtmlContent)
getMessage :: GHandler sub master (Maybe Html)
getMessage = do
clearSession msgKey
fmap (fmap $ Encoded . cs) $ lookupSession msgKey
fmap (fmap $ preEscapedString . cs) $ lookupSession msgKey
-- | Bypass remaining handler code and output the given file.
--

6
Yesod/Helpers/AtomFeed.hs
View File

@ -24,8 +24,6 @@ module Yesod.Helpers.AtomFeed
import Yesod
import Data.Time.Clock (UTCTime)
import Text.Hamlet.Monad
import Text.Hamlet.Quasi
newtype RepAtom = RepAtom Content
instance HasReps RepAtom where
@ -46,10 +44,10 @@ data AtomFeedEntry url = AtomFeedEntry
{ atomEntryLink :: url
, atomEntryUpdated :: UTCTime
, atomEntryTitle :: String
, atomEntryContent :: HtmlContent
, atomEntryContent :: Html
}
xmlns :: AtomFeed url -> HtmlContent
xmlns :: AtomFeed url -> Html
xmlns _ = cs "http://www.w3.org/2005/Atom"
template :: AtomFeed url -> Hamlet url

2
Yesod/Helpers/Sitemap.hs
View File

@ -50,7 +50,7 @@ data SitemapUrl url = SitemapUrl
, priority :: Double
}
sitemapNS :: HtmlContent
sitemapNS :: Html
sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9"
template :: [SitemapUrl url] -> Hamlet url

44
Yesod/Json.hs
View File

@ -16,7 +16,6 @@ module Yesod.Json
)
where
import Text.Hamlet.Monad
import qualified Data.ByteString.Char8 as S8
import Data.Char (isControl)
import Yesod.Hamlet
@ -25,6 +24,7 @@ import Web.Routes.Quasi (Routes)
import Numeric (showHex)
import Data.Monoid (Monoid (..))
import Data.Convertible.Text (cs)
import Text.Hamlet
#if TEST
import Test.Framework (testGroup, Test)
@ -43,17 +43,17 @@ import Yesod.Content
-- This is an opaque type to avoid any possible insertion of non-JSON content.
-- Due to the limited nature of the JSON format, you can create any valid JSON
-- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'.
newtype Json url = Json { unJson :: Hamlet url }
newtype Json = Json { unJson :: Html }
deriving Monoid
-- | Extract the final result from the given 'Json' value.
--
-- See also: applyLayoutJson in "Yesod.Yesod".
jsonToContent :: Json (Routes master) -> GHandler sub master Content
jsonToContent = hamletToContent . unJson
jsonToContent :: Json -> GHandler sub master Content
jsonToContent = return . toContent . renderHtml . unJson
-- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'.
jsonToRepJson :: Json (Routes master) -> GHandler sub master RepJson
jsonToRepJson :: Json -> GHandler sub master RepJson
jsonToRepJson = fmap RepJson . jsonToContent
-- | Outputs a single scalar. This function essentially:
@ -63,14 +63,14 @@ jsonToRepJson = fmap RepJson . jsonToContent
-- * Performs JSON encoding.
--
-- * Wraps the resulting string in quotes.
jsonScalar :: HtmlContent -> Json url
jsonScalar :: Html -> Json
jsonScalar s = Json $ mconcat
[ outputString "\""
, output $ encodeJson $ htmlContentToByteString s
, outputString "\""
[ preEscapedString "\""
, preEscapedString $ encodeJson $ cs $ renderHtml s
, preEscapedString "\""
]
where
encodeJson = S8.concatMap (S8.pack . encodeJsonChar)
encodeJson = concatMap encodeJsonChar
encodeJsonChar '\b' = "\\b"
encodeJsonChar '\f' = "\\f"
@ -88,31 +88,31 @@ jsonScalar s = Json $ mconcat
encodeJsonChar c = [c]
-- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"].
jsonList :: [Json url] -> Json url
jsonList [] = Json $ outputOctets "[]"
jsonList :: [Json] -> Json
jsonList [] = Json $ preEscapedString "[]"
jsonList (x:xs) = mconcat
[ Json $ outputOctets "["
[ Json $ preEscapedString "["
, x
, mconcat $ map go xs
, Json $ outputOctets "]"
, Json $ preEscapedString "]"
]
where
go j = mappend (Json $ outputOctets ",") j
go j = mappend (Json $ preEscapedString ",") j
-- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}.
jsonMap :: [(String, Json url)] -> Json url
jsonMap [] = Json $ outputOctets "{}"
jsonMap :: [(String, Json)] -> Json
jsonMap [] = Json $ preEscapedString "{}"
jsonMap (x:xs) = mconcat
[ Json $ outputOctets "{"
[ Json $ preEscapedString "{"
, go x
, mconcat $ map go' xs
, Json $ outputOctets "}"
, Json $ preEscapedString "}"
]
where
go' y = mappend (Json $ outputOctets ",") $ go y
go' y = mappend (Json $ preEscapedString ",") $ go y
go (k, v) = mconcat
[ jsonScalar $ Unencoded $ cs k
, Json $ outputOctets ":"
[ jsonScalar $ string k
, Json $ preEscapedString ":"
, v
]

4
Yesod/Yesod.hs
View File

@ -110,7 +110,7 @@ applyLayoutJson :: Yesod master
=> String -- ^ title
-> Hamlet (Routes master) -- ^ head
-> Hamlet (Routes master) -- ^ body
-> Json (Routes master)
-> Json
-> GHandler sub master RepHtmlJson
applyLayoutJson t h html json = do
html' <- defaultLayout PageContent
@ -135,7 +135,7 @@ defaultErrorHandler NotFound = do
r <- waiRequest
applyLayout' "Not Found" $ [$hamlet|
%h1 Not Found
%p $Unencoded.cs.pathInfo.r$
%p $string.cs.pathInfo.r$
|]
where
pathInfo = W.pathInfo