Commit 3de1b3f4 authored by David L. L. Thomas's avatar David L. L. Thomas

marked quasiquoter for reporting location in tests

parent 5094b1ca
......@@ -257,6 +257,8 @@ test-suite test
hs-source-dirs: tests
ghc-options: -Wall
extensions: QuasiQuotes
build-depends: base
, Snowdrift
, yesod-test
......@@ -281,3 +283,7 @@ test-suite test
, xml-conduit
, esqueleto
, HUnit
, template-haskell
, haskell-src-exts
, haskell-src-meta
, lifted-base
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module BlogTest
( blogSpecs
) where
......@@ -22,7 +23,7 @@ import Data.Maybe (fromMaybe)
blogSpecs :: Spec
blogSpecs = do
let postBlog route stmts = do
let postBlog route stmts = [marked|
get route
statusIs 200
......@@ -39,8 +40,9 @@ blogSpecs = do
stmts
statusIsResp 302
|]
previewBlog route stmts = do
previewBlog route stmts = [marked|
get route
statusIs 200
......@@ -57,12 +59,13 @@ blogSpecs = do
stmts
statusIs 200
|]
ydescribe "blog" $ do
yit "loads the project page - no blog post" $ do
yit "loads the project page - no blog post" $ [marked|
login
get $ ProjectR "snowdrift"
......@@ -73,9 +76,10 @@ blogSpecs = do
htmlNoneContain "#post" "Above fold."
htmlNoneContain "#post" "Below fold."
-}
|]
yit "loads the project blog - no blog post" $ do
yit "loads the project blog - no blog post" $ [marked|
login
get $ ProjectBlogR "snowdrift"
......@@ -84,9 +88,10 @@ blogSpecs = do
htmlNoneContain ".post" "Above fold."
htmlNoneContain ".post" "Below fold."
|]
yit "previews blog post" $ do
yit "previews blog post" $ [marked|
login
previewBlog (NewProjectBlogPostR "snowdrift") $ do
......@@ -96,9 +101,10 @@ blogSpecs = do
bodyContains "Above fold."
bodyContains "Below fold."
|]
yit "posts blog post" $ do
yit "posts blog post" $ [marked|
login
postBlog (NewProjectBlogPostR "snowdrift") $ do
......@@ -119,9 +125,9 @@ blogSpecs = do
htmlAnyContain ".post" "Above fold."
htmlAnyContain ".post" "Below fold."
|]
yit "loads the project blog - with blog post" $ do
yit "loads the project blog - with blog post" $ [marked|
login
get $ ProjectBlogR "snowdrift"
......@@ -130,9 +136,10 @@ blogSpecs = do
htmlAnyContain ".post" "Above fold."
htmlNoneContain ".post" "Below fold."
|]
{-
yit "loads the project page - with blog post" $ do
yit "loads the project page - with blog post" $ [marked|
login
get $ ProjectR "snowdrift"
......@@ -141,6 +148,7 @@ blogSpecs = do
htmlAllContain "#post" "Above fold."
htmlNoneContain "#post" "Below fold."
|]
-}
......
......@@ -19,7 +19,7 @@ import Control.Monad
discussionSpecs :: Spec
discussionSpecs = do
let postComment route stmts = do
let postComment route stmts = [marked|
get route
statusIs 200
......@@ -35,19 +35,22 @@ discussionSpecs = do
stmts
statusIsResp 302
|]
getLatestCommentId = do
getLatestCommentId = [marked|
[ Value (Just comment_id) ] <- testDB $ select $ from $ \ comment -> return (max_ $ comment ^. CommentId)
return comment_id
|]
ydescribe "discussion" $ do
yit "loads the discussion page" $ do
yit "loads the discussion page" $ [marked|
login
get $ DiscussWikiR "snowdrift" "about"
statusIs 200
|]
yit "posts and moves some comments" $ do
yit "posts and moves some comments" $ [marked|
login
liftIO $ putStrLn "posting root comment"
......@@ -78,18 +81,20 @@ discussionSpecs = do
addPostParam "mode" "rethread"
statusIsResp 302
|]
ydescribe "discussion - rethreading" $ do
let createComments = do
let createComments = [marked|
postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "First message"
first <- getLatestCommentId
postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "Second message"
second <- getLatestCommentId
return (first, second)
|]
testRethread first second = do
testRethread first second = [marked|
let rethread_url c = RethreadWikiCommentR "snowdrift" "about" c
get $ rethread_url first
......@@ -112,9 +117,10 @@ discussionSpecs = do
bodyContains "First message"
bodyContains "Second message"
|]
yit "can move newer comments under older" $ do
yit "can move newer comments under older" $ [marked|
login
get $ NewDiscussWikiR "snowdrift" "about"
......@@ -123,9 +129,10 @@ discussionSpecs = do
(first, second) <- createComments
testRethread first second
|]
yit "can move older comments under newer" $ do
yit "can move older comments under newer" $ [marked|
login
get $ NewDiscussWikiR "snowdrift" "about"
......@@ -134,8 +141,9 @@ discussionSpecs = do
(first, second) <- createComments
testRethread second first
|]
yit "can rethread across pages and the redirect still works" $ do
yit "can rethread across pages and the redirect still works" $ [marked|
login
postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "posting on about page"
......@@ -168,5 +176,6 @@ discussionSpecs = do
desired_url = "http://localhost:3000/p/snowdrift/w/intro/c/" ++ (\ (PersistInt64 i) -> show i) (unKey newId)
assertEqual ("Redirect not matching! (" ++ show new_url ++ " /= " ++ show desired_url ++ ")") new_url desired_url
|]
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
module TestImport
( runDB
......@@ -10,6 +11,7 @@ module TestImport
, liftIO
, extractLocation
, statusIsResp
, onException
, module TestImport
) where
......@@ -36,6 +38,19 @@ import Model as TestImport
import Control.Monad (when)
import qualified Language.Haskell.Meta.Parse as Exp
import qualified Language.Haskell.Meta.Syntax.Translate as Exp
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
import qualified Language.Haskell.Exts.Parser as Src
import qualified Language.Haskell.Exts.SrcLoc as Src
import qualified Language.Haskell.Exts.Pretty as Src
import qualified Language.Haskell.Exts.Annotated.Syntax as Src
import Control.Exception.Lifted
type Spec = YesodSpec App
type Example = YesodExample App
......@@ -122,3 +137,39 @@ statusIsResp number = withResponse $ \ SResponse { simpleStatus = s } -> do
, " but received status was ", show $ H.statusCode s
]
marked :: QuasiQuoter
marked = QuasiQuoter { quoteExp = decorate }
where
decorate input = do
loc <- TH.location
let file = TH.loc_filename loc
(line, _) = TH.loc_start loc
fixup 1 = 0
fixup x = x - 2
onException l = Src.QVarOp l $ Src.Qual l (Src.ModuleName l "TestImport") (Src.Ident l "onException")
report l =
let str = file ++ ":" ++ show (line + fixup (Src.srcLine l)) ++ ": exception raised here"
in Src.App l
(Src.Var l $ Src.Qual l (Src.ModuleName l "TestImport") (Src.Ident l "liftIO"))
$ Src.App l
(Src.Var l $ Src.Qual l (Src.ModuleName l "Prelude") (Src.Ident l "putStrLn"))
(Src.Lit l $ Src.String l str str)
mark l e = Src.InfixApp l e (onException l) (report l)
decorateExp :: Src.Exp Src.SrcLoc -> Src.Exp Src.SrcLoc
decorateExp (Src.Do l stmts) = mark l $ Src.Do l $ map decorateStmt stmts
decorateExp exp = mark (Src.ann exp) exp
decorateStmt :: Src.Stmt Src.SrcLoc -> Src.Stmt Src.SrcLoc
decorateStmt (Src.Generator l pat exp) = Src.Generator l pat $ decorateExp exp
decorateStmt (Src.Qualifier l exp) = Src.Qualifier l $ decorateExp exp
decorateStmt stmt = stmt
case Src.parse ("do\n" ++ input) of
Src.ParseOk a -> either fail return $ Exp.parseExp $ Src.prettyPrint $ decorateExp a
Src.ParseFailed l e -> fail e
......@@ -9,7 +9,7 @@ wikiSpecs :: Spec
wikiSpecs =
ydescribe "wiki" $ do
yit "creates a new page" $ do
yit "creates a new page" $ [marked|
login
......@@ -30,4 +30,5 @@ wikiSpecs =
setMethod "POST"
byLabel "Page Content" "test"
addPostParam "mode" "post"
|]
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment