{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.Widget (widgetTest) where import Test.Hspec import Test.Hspec.HUnit () import Yesod.Core hiding (Request) 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 RepHtml 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 getTowidgetR :: Handler RepHtml getTowidgetR = defaultLayout $ do toWidget [julius|foo|] :: Widget toWidgetHead [julius|foo|] toWidgetBody [julius|foo|] toWidget [lucius|foo{bar:baz}|] toWidgetHead [lucius|foo{bar:baz}|] toWidget [hamlet||] toWidgetHead [hamlet||] toWidgetBody [hamlet||] getWhamletR :: Handler RepHtml getWhamletR = defaultLayout [whamlet| $newline never

Test

@{WhamletR}

_{Goodbye}

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

Embed |] getAutoR :: Handler RepHtml getAutoR = defaultLayout [whamlet| $newline never ^{someHtml} |] where someHtml = [shamlet|somehtml|] getJSHeadR :: Handler RepHtml getJSHeadR = defaultLayout $ toWidgetHead [julius|alert("hello");|] 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 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