GHC 7 support.
GHC 7 changes the syntax for quasi-quotation. A later patch release (7.0.2) should be adding back backwards-compatibility with the old syntax, but in the meanwhile this (relatively ugly) hack should fix it.
This commit is contained in:
Michael Snoyman
parent
aaed6875c2
commit
92ab8ee889
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | Parse forms (and query strings).
|
||||
module Yesod.Form
|
||||
( -- * Data types
|
||||
@ -72,7 +73,12 @@ fieldsToPlain = mapFormXml $ mapM_ fiInput
|
||||
fieldsToTable :: FormField sub y a -> Form sub y a
|
||||
fieldsToTable = mapFormXml $ mapM_ go
|
||||
where
|
||||
go fi = [$hamlet|
|
||||
go fi =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%tr.$clazz.fi$
|
||||
%td
|
||||
%label!for=$fiIdent.fi$ $fiLabel.fi$
|
||||
@ -88,7 +94,12 @@ fieldsToTable = mapFormXml $ mapM_ go
|
||||
fieldsToDivs :: FormField sub y a -> Form sub y a
|
||||
fieldsToDivs = mapFormXml $ mapM_ go
|
||||
where
|
||||
go fi = [$hamlet|
|
||||
go fi =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
.$clazz.fi$
|
||||
%label!for=$fiIdent.fi$ $fiLabel.fi$
|
||||
.tooltip $fiTooltip.fi$
|
||||
@ -125,7 +136,14 @@ runFormPost f = do
|
||||
_ -> res
|
||||
return (res', xml, enctype, hidden nonce)
|
||||
where
|
||||
hidden nonce = [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|]
|
||||
hidden nonce =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input!type=hidden!name=$nonceName$!value=$nonce$
|
||||
|]
|
||||
|
||||
nonceName :: String
|
||||
nonceName = "_nonce"
|
||||
@ -158,7 +176,12 @@ runFormTable :: Route m -> String -> FormField s m a
|
||||
-> GHandler s m (FormResult a, GWidget s m ())
|
||||
runFormTable dest inputLabel form = do
|
||||
(res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form
|
||||
let widget' = [$hamlet|
|
||||
let widget' =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%form!method=post!action=@dest@!enctype=$enctype$
|
||||
%table
|
||||
^widget^
|
||||
@ -174,7 +197,12 @@ runFormDivs :: Route m -> String -> FormField s m a
|
||||
-> GHandler s m (FormResult a, GWidget s m ())
|
||||
runFormDivs dest inputLabel form = do
|
||||
(res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form
|
||||
let widget' = [$hamlet|
|
||||
let widget' =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%form!method=post!action=@dest@!enctype=$enctype$
|
||||
^widget^
|
||||
%div
|
||||
@ -199,7 +227,14 @@ generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html)
|
||||
generateForm f = do
|
||||
(_, b, c) <- runFormGeneric [] [] f
|
||||
nonce <- fmap reqNonce getRequest
|
||||
return (b, c, [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|])
|
||||
return (b, c,
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input!type=hidden!name=$nonceName$!value=$nonce$
|
||||
|])
|
||||
|
||||
-- | Run a form against GET parameters.
|
||||
runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Form.Fields
|
||||
( -- * Fields
|
||||
-- ** Required
|
||||
@ -126,7 +127,12 @@ boolField ffs orig = toForm $ do
|
||||
{ fiLabel = string label
|
||||
, fiTooltip = tooltip
|
||||
, fiIdent = theId
|
||||
, fiInput = [$hamlet|
|
||||
, fiInput =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!type=checkbox!name=$name$!:val:checked
|
||||
|]
|
||||
, fiErrors = case res of
|
||||
@ -170,7 +176,12 @@ selectField pairs ffs initial = toForm $ do
|
||||
case res of
|
||||
FormSuccess y -> x == y
|
||||
_ -> Just x == initial
|
||||
let input = [$hamlet|
|
||||
let input =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%select#$theId$!name=$name$
|
||||
%option!value=none
|
||||
$forall pairs' pair
|
||||
@ -215,7 +226,12 @@ maybeSelectField pairs ffs initial' = toForm $ do
|
||||
case res of
|
||||
FormSuccess y -> Just x == y
|
||||
_ -> Just x == initial
|
||||
let input = [$hamlet|
|
||||
let input =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%select#$theId$!name=$name$
|
||||
%option!value=none
|
||||
$forall pairs' pair
|
||||
@ -251,7 +267,14 @@ boolInput n = GForm $ do
|
||||
Just "" -> FormSuccess False
|
||||
Just "false" -> FormSuccess False
|
||||
Just _ -> FormSuccess True
|
||||
let xml = [$hamlet|%input#$n$!type=checkbox!name=$n$|]
|
||||
let xml =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$n$!type=checkbox!name=$n$
|
||||
|]
|
||||
return (res, [xml], UrlEncoded)
|
||||
|
||||
dayInput :: String -> FormInput sub master Day
|
||||
@ -356,6 +379,11 @@ maybeFileField ffs = toForm $ do
|
||||
return (res, fi, Multipart)
|
||||
|
||||
fileWidget :: String -> String -> Bool -> GWidget s m ()
|
||||
fileWidget theId name isReq = [$hamlet|
|
||||
fileWidget theId name isReq =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!type=file!name=$name$!:isReq:required
|
||||
|]
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | Some fields spiced up with jQuery UI.
|
||||
module Yesod.Form.Jquery
|
||||
( YesodJquery (..)
|
||||
@ -75,13 +76,23 @@ jqueryDayFieldProfile jds = FieldProfile
|
||||
. readMay
|
||||
, fpRender = show
|
||||
, fpWidget = \theId name val isReq -> do
|
||||
addHtml [$hamlet|
|
||||
addHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
|
||||
|]
|
||||
addScript' urlJqueryJs
|
||||
addScript' urlJqueryUiJs
|
||||
addStylesheet' urlJqueryUiCss
|
||||
addJulius [$julius|
|
||||
addJulius
|
||||
#if GHC7
|
||||
[julius|
|
||||
#else
|
||||
[$julius|
|
||||
#endif
|
||||
$(function(){$("#%theId%").datepicker({
|
||||
dateFormat:'yy-mm-dd',
|
||||
changeMonth:%jsBool.jdsChangeMonth.jds%,
|
||||
@ -133,14 +144,24 @@ jqueryDayTimeFieldProfile = FieldProfile
|
||||
{ fpParse = parseUTCTime
|
||||
, fpRender = jqueryDayTimeUTCTime
|
||||
, fpWidget = \theId name val isReq -> do
|
||||
addHtml [$hamlet|
|
||||
addHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!:isReq:required!value=$val$
|
||||
|]
|
||||
addScript' urlJqueryJs
|
||||
addScript' urlJqueryUiJs
|
||||
addScript' urlJqueryUiDateTimePicker
|
||||
addStylesheet' urlJqueryUiCss
|
||||
addJulius [$julius|
|
||||
addJulius
|
||||
#if GHC7
|
||||
[julius|
|
||||
#else
|
||||
[$julius|
|
||||
#endif
|
||||
$(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});
|
||||
|]
|
||||
}
|
||||
@ -177,13 +198,23 @@ jqueryAutocompleteFieldProfile src = FieldProfile
|
||||
{ fpParse = Right
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> do
|
||||
addHtml [$hamlet|
|
||||
addHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$
|
||||
|]
|
||||
addScript' urlJqueryJs
|
||||
addScript' urlJqueryUiJs
|
||||
addStylesheet' urlJqueryUiCss
|
||||
addJulius [$julius|
|
||||
addJulius
|
||||
#if GHC7
|
||||
[julius|
|
||||
#else
|
||||
[$julius|
|
||||
#endif
|
||||
$(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})});
|
||||
|]
|
||||
}
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | Provide the user with a rich text editor.
|
||||
module Yesod.Form.Nic
|
||||
( YesodNic (..)
|
||||
@ -35,9 +36,23 @@ nicHtmlFieldProfile = FieldProfile
|
||||
{ fpParse = Right . preEscapedString . sanitizeBalance
|
||||
, fpRender = lbsToChars . renderHtml
|
||||
, fpWidget = \theId name val _isReq -> do
|
||||
addHtml [$hamlet|%textarea.html#$theId$!name=$name$ $val$|]
|
||||
addHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%textarea.html#$theId$!name=$name$ $val$
|
||||
|]
|
||||
addScript' urlNicEdit
|
||||
addJulius [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|]
|
||||
addJulius
|
||||
#if GHC7
|
||||
[julius|
|
||||
#else
|
||||
[$julius|
|
||||
#endif
|
||||
bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});
|
||||
|]
|
||||
}
|
||||
|
||||
addScript' :: (y -> Either (Route y) String) -> GWidget sub y ()
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Form.Profiles
|
||||
( stringFieldProfile
|
||||
, textareaFieldProfile
|
||||
@ -35,7 +36,12 @@ intFieldProfile :: Integral i => FieldProfile sub y i
|
||||
intFieldProfile = FieldProfile
|
||||
{ fpParse = maybe (Left "Invalid integer") Right . readMayI
|
||||
, fpRender = showI
|
||||
, fpWidget = \theId name val isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$
|
||||
|]
|
||||
}
|
||||
@ -49,7 +55,12 @@ doubleFieldProfile :: FieldProfile sub y Double
|
||||
doubleFieldProfile = FieldProfile
|
||||
{ fpParse = maybe (Left "Invalid number") Right . readMay
|
||||
, fpRender = show
|
||||
, fpWidget = \theId name val isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$
|
||||
|]
|
||||
}
|
||||
@ -58,7 +69,12 @@ dayFieldProfile :: FieldProfile sub y Day
|
||||
dayFieldProfile = FieldProfile
|
||||
{ fpParse = parseDate
|
||||
, fpRender = show
|
||||
, fpWidget = \theId name val isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
|
||||
|]
|
||||
}
|
||||
@ -67,7 +83,12 @@ timeFieldProfile :: FieldProfile sub y TimeOfDay
|
||||
timeFieldProfile = FieldProfile
|
||||
{ fpParse = parseTime
|
||||
, fpRender = show
|
||||
, fpWidget = \theId name val isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!:isReq:required!value=$val$
|
||||
|]
|
||||
}
|
||||
@ -76,7 +97,12 @@ htmlFieldProfile :: FieldProfile sub y Html
|
||||
htmlFieldProfile = FieldProfile
|
||||
{ fpParse = Right . preEscapedString . sanitizeBalance
|
||||
, fpRender = lbsToChars . renderHtml
|
||||
, fpWidget = \theId name val _isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val _isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%textarea.html#$theId$!name=$name$ $val$
|
||||
|]
|
||||
}
|
||||
@ -102,7 +128,12 @@ textareaFieldProfile :: FieldProfile sub y Textarea
|
||||
textareaFieldProfile = FieldProfile
|
||||
{ fpParse = Right . Textarea
|
||||
, fpRender = unTextarea
|
||||
, fpWidget = \theId name val _isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val _isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%textarea#$theId$!name=$name$ $val$
|
||||
|]
|
||||
}
|
||||
@ -111,7 +142,12 @@ hiddenFieldProfile :: FieldProfile sub y String
|
||||
hiddenFieldProfile = FieldProfile
|
||||
{ fpParse = Right
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val _isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val _isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input!type=hidden#$theId$!name=$name$!value=$val$
|
||||
|]
|
||||
}
|
||||
@ -120,7 +156,12 @@ stringFieldProfile :: FieldProfile sub y String
|
||||
stringFieldProfile = FieldProfile
|
||||
{ fpParse = Right
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$
|
||||
|]
|
||||
}
|
||||
@ -169,7 +210,12 @@ emailFieldProfile = FieldProfile
|
||||
then Right s
|
||||
else Left "Invalid e-mail address"
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$
|
||||
|]
|
||||
}
|
||||
@ -180,7 +226,12 @@ urlFieldProfile = FieldProfile
|
||||
Nothing -> Left "Invalid URL"
|
||||
Just _ -> Right s
|
||||
, fpRender = id
|
||||
, fpWidget = \theId name val isReq -> addHamlet [$hamlet|
|
||||
, fpWidget = \theId name val isReq -> addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$
|
||||
|]
|
||||
}
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Helpers.AtomFeed
|
||||
@ -49,7 +50,12 @@ data AtomFeedEntry url = AtomFeedEntry
|
||||
}
|
||||
|
||||
template :: AtomFeed url -> Hamlet url
|
||||
template arg = [$xhamlet|
|
||||
template arg =
|
||||
#if GHC7
|
||||
[xhamlet|
|
||||
#else
|
||||
[$xhamlet|
|
||||
#endif
|
||||
<?xml version="1.0" encoding="utf-8"?>
|
||||
%feed!xmlns="http://www.w3.org/2005/Atom"
|
||||
%title $atomTitle.arg$
|
||||
@ -62,7 +68,12 @@ template arg = [$xhamlet|
|
||||
|]
|
||||
|
||||
entryTemplate :: AtomFeedEntry url -> Hamlet url
|
||||
entryTemplate arg = [$xhamlet|
|
||||
entryTemplate arg =
|
||||
#if GHC7
|
||||
[xhamlet|
|
||||
#else
|
||||
[$xhamlet|
|
||||
#endif
|
||||
%entry
|
||||
%id @atomEntryLink.arg@
|
||||
%link!href=@atomEntryLink.arg@
|
||||
@ -75,6 +86,11 @@ entryTemplate arg = [$xhamlet|
|
||||
atomLink :: Route m
|
||||
-> String -- ^ title
|
||||
-> GWidget s m ()
|
||||
atomLink u title = addHamletHead [$hamlet|
|
||||
atomLink u title = addHamletHead
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$
|
||||
|]
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Yesod.Helpers.Crud
|
||||
( Item (..)
|
||||
, Crud (..)
|
||||
@ -41,7 +42,12 @@ mkYesodSub "Crud master item"
|
||||
, ClassP ''Item [VarT $ mkName "item"]
|
||||
, ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")]
|
||||
, ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"]
|
||||
] [$parseRoutes|
|
||||
]
|
||||
#if GHC7
|
||||
[parseRoutes|
|
||||
#else
|
||||
[$parseRoutes|
|
||||
#endif
|
||||
/ CrudListR GET
|
||||
/add CrudAddR GET POST
|
||||
/edit/#String CrudEditR GET POST
|
||||
@ -55,7 +61,12 @@ getCrudListR = do
|
||||
toMaster <- getRouteToMaster
|
||||
defaultLayout $ do
|
||||
setTitle "Items"
|
||||
addWidget [$hamlet|
|
||||
addWidget
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h1 Items
|
||||
%ul
|
||||
$forall items item
|
||||
@ -115,7 +126,12 @@ getCrudDeleteR s = do
|
||||
toMaster <- getRouteToMaster
|
||||
defaultLayout $ do
|
||||
setTitle "Confirm delete"
|
||||
addWidget [$hamlet|
|
||||
addWidget
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%form!method=post!action=@toMaster.CrudDeleteR.s@
|
||||
%h1 Really delete?
|
||||
%p Do you really want to delete $itemTitle.item$?
|
||||
@ -157,7 +173,12 @@ crudHelper title me isPost = do
|
||||
_ -> return ()
|
||||
defaultLayout $ do
|
||||
setTitle $ string title
|
||||
addWidget [$hamlet|
|
||||
addWidget
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%p
|
||||
%a!href=@toMaster.CrudListR@ Return to list
|
||||
%h1 $title$
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Helpers.Sitemap
|
||||
@ -51,7 +52,12 @@ data SitemapUrl url = SitemapUrl
|
||||
}
|
||||
|
||||
template :: [SitemapUrl url] -> Hamlet url
|
||||
template urls = [$hamlet|
|
||||
template urls =
|
||||
#if GHC7
|
||||
[xhamlet|
|
||||
#else
|
||||
[$xhamlet|
|
||||
#endif
|
||||
%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9"
|
||||
$forall urls url
|
||||
%url
|
||||
@ -69,4 +75,5 @@ robots :: Route sub -- ^ sitemap url
|
||||
-> GHandler sub master RepPlain
|
||||
robots smurl = do
|
||||
tm <- getRouteToMaster
|
||||
RepPlain `fmap` hamletToContent [$hamlet|Sitemap: @tm.smurl@|]
|
||||
render <- getUrlRender
|
||||
return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl)
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- | Normal users should never need access to these.
|
||||
module Yesod.Internal
|
||||
( -- * Error responses
|
||||
@ -39,6 +40,12 @@ import qualified Data.Text.Encoding.Error as T
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import qualified Data.Text.Lazy.Encoding as LT
|
||||
|
||||
#if GHC7
|
||||
#define HAMLET hamlet
|
||||
#else
|
||||
#define HAMLET $hamlet
|
||||
#endif
|
||||
|
||||
-- | Responses to indicate some form of an error occurred. These are different
|
||||
-- from 'SpecialResponse' in that they allow for custom error pages.
|
||||
data ErrorResponse =
|
||||
@ -63,8 +70,8 @@ langKey = "_LANG"
|
||||
data Location url = Local url | Remote String
|
||||
deriving (Show, Eq)
|
||||
locationToHamlet :: Location url -> Hamlet url
|
||||
locationToHamlet (Local url) = [$hamlet|@url@|]
|
||||
locationToHamlet (Remote s) = [$hamlet|$s$|]
|
||||
locationToHamlet (Local url) = [HAMLET|@url@|]
|
||||
locationToHamlet (Remote s) = [HAMLET|$s$|]
|
||||
|
||||
newtype UniqueList x = UniqueList ([x] -> [x])
|
||||
instance Monoid (UniqueList x) where
|
||||
|
||||
@ -73,6 +73,12 @@ import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.HUnit hiding (Test)
|
||||
#endif
|
||||
|
||||
#if GHC7
|
||||
#define HAMLET hamlet
|
||||
#else
|
||||
#define HAMLET $hamlet
|
||||
#endif
|
||||
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
class Eq (Route y) => YesodSite y where
|
||||
@ -117,7 +123,7 @@ class Eq (Route a) => Yesod a where
|
||||
defaultLayout w = do
|
||||
p <- widgetToPageContent w
|
||||
mmsg <- getMessage
|
||||
hamletToRepHtml [$hamlet|
|
||||
hamletToRepHtml [HAMLET|
|
||||
!!!
|
||||
%html
|
||||
%head
|
||||
@ -312,31 +318,56 @@ defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
|
||||
defaultErrorHandler NotFound = do
|
||||
r <- waiRequest
|
||||
let path' = bsToChars $ pathInfo r
|
||||
applyLayout' "Not Found" $ [$hamlet|
|
||||
applyLayout' "Not Found" [hamlet|
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h1 Not Found
|
||||
%p $path'$
|
||||
|]
|
||||
where
|
||||
pathInfo = W.pathInfo
|
||||
defaultErrorHandler (PermissionDenied msg) =
|
||||
applyLayout' "Permission Denied" $ [$hamlet|
|
||||
applyLayout' "Permission Denied"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h1 Permission denied
|
||||
%p $msg$
|
||||
|]
|
||||
defaultErrorHandler (InvalidArgs ia) =
|
||||
applyLayout' "Invalid Arguments" $ [$hamlet|
|
||||
applyLayout' "Invalid Arguments"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h1 Invalid Arguments
|
||||
%ul
|
||||
$forall ia msg
|
||||
%li $msg$
|
||||
|]
|
||||
defaultErrorHandler (InternalError e) =
|
||||
applyLayout' "Internal Server Error" $ [$hamlet|
|
||||
applyLayout' "Internal Server Error"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h1 Internal Server Error
|
||||
%p $e$
|
||||
|]
|
||||
defaultErrorHandler (BadMethod m) =
|
||||
applyLayout' "Bad Method" $ [$hamlet|
|
||||
applyLayout' "Bad Method"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
%h1 Method Not Supported
|
||||
%p Method "$m$" not supported
|
||||
|]
|
||||
@ -416,7 +447,12 @@ widgetToPageContent (GWidget w) = do
|
||||
$ renderJulius render s
|
||||
return $ renderLoc x
|
||||
|
||||
let head'' = [$hamlet|
|
||||
let head'' =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
$forall scripts s
|
||||
%script!src=^s^
|
||||
$forall stylesheets s
|
||||
@ -490,7 +526,12 @@ caseUtf8JoinPath = do
|
||||
-- useful when you need to post a plain link somewhere that needs to cause
|
||||
-- changes on the server.
|
||||
redirectToPost :: Route master -> GHandler sub master a
|
||||
redirectToPost dest = hamletToRepHtml [$hamlet|
|
||||
redirectToPost dest = hamletToRepHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
!!!
|
||||
%html
|
||||
%head
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
import CodeGen
|
||||
import System.IO
|
||||
import System.Directory
|
||||
@ -10,6 +11,13 @@ import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import qualified Data.Text.Lazy.Encoding as LT
|
||||
|
||||
qq :: String
|
||||
#if GHC7
|
||||
qq = ""
|
||||
#else
|
||||
qq = "$"
|
||||
#endif
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStr $(codegen "welcome")
|
||||
|
||||
@ -8,7 +8,7 @@ import Database.Persist.GenericSql (mkMigrate)
|
||||
-- You can define all of your database entities here. You can find more
|
||||
-- information on persistent and how to declare entities at:
|
||||
-- http://docs.yesodweb.com/book/persistent/
|
||||
share2 mkPersist (mkMigrate "migrateAll") [$persist|
|
||||
share2 mkPersist (mkMigrate "migrateAll") [~qq~persist|
|
||||
User
|
||||
ident String
|
||||
password String null update
|
||||
|
||||
@ -68,7 +68,7 @@ type Widget = GWidget ~sitearg~ ~sitearg~
|
||||
-- for our application to be in scope. However, the handler functions
|
||||
-- usually require access to the ~sitearg~Route datatype. Therefore, we
|
||||
-- split these actions into two functions and place them in separate files.
|
||||
mkYesodData "~sitearg~" [$parseRoutes|
|
||||
mkYesodData "~sitearg~" [~qq~parseRoutes|
|
||||
/static StaticR Static getStatic
|
||||
/auth AuthR Auth getAuth
|
||||
|
||||
@ -175,7 +175,7 @@ instance YesodAuthEmail ~sitearg~ where
|
||||
{ partType = "text/html; charset=utf-8"
|
||||
, partEncoding = None
|
||||
, partFilename = Nothing
|
||||
, partContent = renderHtml [$hamlet|
|
||||
, partContent = renderHtml [~qq~hamlet|
|
||||
%p Please confirm your email address by clicking on the link below.
|
||||
%p
|
||||
%a!href=$verurl$ $verurl$
|
||||
|
||||
20
yesod.cabal
20
yesod.cabal
@ -20,9 +20,15 @@ flag test
|
||||
description: Build the executable to run unit tests
|
||||
default: False
|
||||
|
||||
flag ghc7
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, time >= 1.1.4 && < 1.3
|
||||
if flag(ghc7)
|
||||
build-depends: base >= 4.3 && < 5
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
build-depends: base >= 4 && < 4.3
|
||||
build-depends: time >= 1.1.4 && < 1.3
|
||||
, wai >= 0.2.0 && < 0.3
|
||||
, wai-extra >= 0.2.4 && < 0.3
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
@ -72,6 +78,11 @@ library
|
||||
ghc-options: -Wall
|
||||
|
||||
executable yesod
|
||||
if flag(ghc7)
|
||||
build-depends: base >= 4.3 && < 5
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
build-depends: base >= 4 && < 4.3
|
||||
build-depends: parsec >= 2.1 && < 4
|
||||
ghc-options: -Wall
|
||||
main-is: scaffold.hs
|
||||
@ -79,6 +90,11 @@ executable yesod
|
||||
extensions: TemplateHaskell
|
||||
|
||||
executable runtests
|
||||
if flag(ghc7)
|
||||
build-depends: base >= 4.3 && < 5
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
build-depends: base >= 4 && < 4.3
|
||||
if flag(test)
|
||||
Buildable: True
|
||||
cpp-options: -DTEST
|
||||
|
||||
Loading…
Reference in New Issue
Block a user