{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} module YesodCoreTest.Widget (widgetTest) where import Test.Hspec import Yesod.Core import Text.Julius import Text.Lucius import Text.Hamlet import Network.Wai import Network.Wai.Test data Y = Y mkMessage "Y" "test" "en" type Strings = [String] mkYesod "Y" [parseRoutes| / RootR GET /foo/*Strings MultiR GET /whamlet WhamletR GET /towidget TowidgetR GET /auto AutoR GET /jshead JSHeadR GET |] instance Yesod Y where approot = ApprootStatic "http://test" getRootR :: Handler Html getRootR = defaultLayout $ toWidgetBody [julius||] getMultiR :: [String] -> Handler () getMultiR _ = return () data Msg = Hello | Goodbye instance RenderMessage Y Msg where renderMessage _ ("en":_) Hello = "Hello" renderMessage _ ("es":_) Hello = "Hola" renderMessage _ ("en":_) Goodbye = "Goodbye" renderMessage _ ("es":_) Goodbye = "Adios" renderMessage a (_:xs) y = renderMessage a xs y renderMessage a [] y = renderMessage a ["en"] y getWhamletR :: Handler Html getWhamletR = defaultLayout [whamlet| $newline never

Test

@{WhamletR}

_{Goodbye}

_{MsgAnother} ^{embed} |] where embed = [whamlet| $newline never

Embed |] getAutoR :: Handler Html getAutoR = defaultLayout [whamlet| $newline never ^{someHtml} |] where someHtml = [shamlet|somehtml|] getJSHeadR :: Handler Html getJSHeadR = defaultLayout $ toWidgetHead [julius|alert("hello");|] getTowidgetR :: Handler Html getTowidgetR = defaultLayout $ do toWidget [julius|toWidget|] :: Widget toWidgetHead [julius|toHead|] toWidgetBody [julius|toBody|] toWidget [lucius|toWidget{bar:baz}|] toWidgetHead [lucius|toHead{bar:baz}|] toWidget [hamlet|
toWidget|] toWidgetHead [hamlet||] toWidgetBody [hamlet|
toBody|] widgetTest :: Spec widgetTest = describe "Test.Widget" $ do it "addJuliusBody" case_addJuliusBody it "whamlet" case_whamlet it "two letter lang codes" case_two_letter_lang it "automatically applies toWidget" case_auto it "toWidgetHead puts JS in head" case_jshead it "toWidget" $ runner $ do res <- request defaultRequest { pathInfo = ["towidget"] } assertBody "\n\n
toWidget
\n
toBody
\n" res runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f case_addJuliusBody :: IO () case_addJuliusBody = runner $ do res <- request defaultRequest assertBody "\n" res case_whamlet :: IO () case_whamlet = runner $ do res <- request defaultRequest { pathInfo = ["whamlet"] , requestHeaders = [("Accept-Language", "es")] } assertBody "\n

Test

http://test/whamlet

Adios

String

Embed

" res case_two_letter_lang :: IO () case_two_letter_lang = runner $ do res <- request defaultRequest { pathInfo = ["whamlet"] , requestHeaders = [("Accept-Language", "es-ES")] } assertBody "\n

Test

http://test/whamlet

Adios

String

Embed

" res case_auto :: IO () case_auto = runner $ do res <- request defaultRequest { pathInfo = ["auto"] , requestHeaders = [("Accept-Language", "es")] } assertBody "\nsomehtml" res case_jshead :: IO () case_jshead = runner $ do res <- request defaultRequest { pathInfo = ["jshead"] } assertBody "\n" res assertHeader "Vary" "Accept, Accept-Language" res