descriptive-0.9.1: src/test/Main.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-- | Test suite for ACE.
module Main where
import Control.Applicative
import Data.Aeson (Value(..),toJSON,object,(.=))
import qualified Data.Map.Strict as M
import Data.Monoid
import Data.Text (Text)
import Descriptive
import qualified Descriptive.Char as Char
import qualified Descriptive.Form as Form
import qualified Descriptive.Formlet as Formlet
import qualified Descriptive.JSON as JSON
import qualified Descriptive.Options as Options
import Test.Hspec (Spec,it,hspec)
import qualified Test.Hspec as Hspec
-- | Test suite entry point, returns exit failure if any test fails.
main :: IO ()
main = hspec spec
-- | Test suite.
spec :: Spec
spec = do
Hspec.describe "Descriptive.Char" characters
Hspec.describe "Descriptive.Form" form
Hspec.describe "Descriptive.Formlet" formlet
Hspec.describe "Descriptive.JSON" json
Hspec.describe "Descriptive.Options" options
--------------------------------------------------------------------------------
-- Character parsing tests
characters :: Spec
characters =
do it "describe"
(describe (many (Char.char 'k') <>
Char.string "abc")
mempty ==
And (Bounded 0 UnlimitedBound (Unit "k"))
(Sequence [Unit "a",Unit "b",Unit "c",None]))
it "consume"
(consume (many (Char.char 'k') <>
Char.string "abc")
"kkkabc" ==
(Succeeded "kkkabc"))
it "fail generic"
(consume (many (Char.char 'k') <>
Char.string "abc")
"kkkab" ==
(Failed (Unit "a character")))
it "fail specific"
(consume (many (Char.char 'k') <>
Char.string "abc")
"kkkabj" ==
(Failed (Unit "c")))
--------------------------------------------------------------------------------
-- Form tests
form :: Spec
form =
do it "basic describe login"
(describe ((,) <$>
Form.input "username" <*>
Form.input "password")
mempty ==
(And (Unit (Form.Input "username"))
(Unit (Form.Input "password"))))
it "basic describe login"
(consume ((,) <$>
Form.input "username" <*>
Form.input "password")
(M.fromList [("username","chrisdone"),("password","god")]) ==
Succeeded ("chrisdone","god"))
it "succeeding login"
(consume login (M.fromList [("password2","gob"),("password","gob")]) ==
Succeeded "gob")
it "continuing login"
(consume login (M.fromList [("password2","gob"),("password","go")]) ==
Continued (And (Wrap (Form.Constraint "confirmed password (entered the same twice)")
(And (Unit (Form.Input "password"))
(Unit (Form.Input "password2"))))
(Unit (Form.Input "token"))))
it "succeeding disjunction"
(consume login
(M.fromList
[("password2","gob"),("password","go"),("token","woot")]) ==
Succeeded "woot")
where login =
Form.validate
"confirmed password (entered the same twice)"
(\(x,y) ->
return (if x == y
then Just y
else Nothing))
((,) <$>
Form.input "password" <*>
Form.input "password2") <|>
Form.input "token"
--------------------------------------------------------------------------------
-- Formlet tests
formlet :: Spec
formlet =
do it "basic formlet"
(describe ((,) <$> Formlet.indexed <*> Formlet.indexed)
(Formlet.FormletState mempty 0) ==
And (Unit (Formlet.Index 0))
(Unit (Formlet.Index 1)))
it "succeeding formlet"
(consume ((,) <$> Formlet.indexed <*> Formlet.indexed)
(Formlet.FormletState (M.fromList [(0,"chrisdone"),(1,"god")])
0) ==
Succeeded ("chrisdone","god"))
it "succeeding formlet"
(consume ((,) <$> Formlet.indexed <*> Formlet.indexed)
(Formlet.FormletState (M.fromList [(0,"chrisdone")])
0) ==
Failed (Unit (Formlet.Index 1)))
--------------------------------------------------------------------------------
-- Options tests
options :: Spec
options =
do it "describe options"
(describe server [] ==
And (And (And (Unit (Options.Constant "start" "cmd"))
(Unit (Options.AnyString "SERVER_NAME")))
(Or (Unit (Options.Flag "dev" "Enable dev mode?")) None))
(Unit (Options.Arg "port" "Port to listen on")))
it "succeeding options"
(consume server ["start","any","--port","1234","--dev"] ==
Succeeded ((),"any",True,"1234"))
it "succeeding omitting port options"
(consume server ["start","any","--port","1234"] ==
Succeeded ((),"any",False,"1234"))
it "failing options"
(consume server ["start","any"] ==
Failed (Unit (Options.Arg "port" "Port to listen on")))
where server =
((,,,) <$>
Options.constant "start" "cmd" () <*>
Options.anyString "SERVER_NAME" <*>
Options.switch "dev" "Enable dev mode?" <*>
Options.arg "port" "Port to listen on")
--------------------------------------------------------------------------------
-- JSON tests
-- | Submit a URL to reddit.
data Submission =
Submission {submissionToken :: !Integer
,submissionTitle :: !Text
,submissionComment :: !Text
,submissionSubreddit :: !Integer}
deriving (Show,Eq)
submission :: Monad m => Consumer Value (JSON.Doc Text) m Submission
submission =
JSON.object "Submission"
(Submission
<$> JSON.key "token" (JSON.integer "Submission token; see the API docs")
<*> JSON.key "title" (JSON.string "Submission title")
<*> JSON.key "comment" (JSON.string "Submission comment")
<*> JSON.key "subreddit" (JSON.integer "The ID of the subreddit"))
sample :: Value
sample =
toJSON (object
["token" .= 123
,"title" .= "Some title"
,"comment" .= "This is good"
,"subreddit" .= 234214])
badsample :: Value
badsample =
toJSON (object
["token" .= 123
,"title" .= "Some title"
,"comment" .= 123
,"subreddit" .= 234214])
json :: Spec
json =
do it "describe JSON"
(describe submission (toJSON ()) ==
Wrap (JSON.Object "Submission")
(And (And (And (Wrap (JSON.Key "token")
(Unit (JSON.Integer "Submission token; see the API docs")))
(Wrap (JSON.Key "title")
(Unit (JSON.Text "Submission title"))))
(Wrap (JSON.Key "comment")
(Unit (JSON.Text "Submission comment"))))
(Wrap (JSON.Key "subreddit")
(Unit (JSON.Integer "The ID of the subreddit")))))
it "succeeding json"
(consume submission sample ==
Succeeded (Submission {submissionToken = 123
,submissionTitle = "Some title"
,submissionComment = "This is good"
,submissionSubreddit = 234214}))
it "failing json"
(consume submission badsample ==
Continued (Wrap (JSON.Object "Submission")
(Wrap (JSON.Key "comment")
(Unit (JSON.Text "Submission comment")))))