1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module Text.BBCode.LexerSpec (spec) where
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck (Property, Discard(..), property)
import Test.QuickCheck.Instances
import Text.BBCode.Lexer
import Data.Text (Text)
import qualified Data.Text as T (singleton, replace, last, null, init)
import Data.Monoid ((<>), mconcat, Endo(..))
import Data.List (intersperse)
import Data.Attoparsec.Text (parseOnly, endOfInput)
import Control.Applicative
import Control.Monad (zipWithM_)
coToken :: BBToken -> Text
-- ^ Inverse of `token`
coToken (BBOpen t []) = "[" <> escape [']'] t <> "]"
coToken (BBOpen t xs) = "[" <> escape [']'] t <> " " <> attrs <> " ]"
where
attrs = mconcat . intersperse " " $ map attr xs
attr (key, "") = escape ['=', ']', ' '] key
attr (key, val) = escape ['=', ']', ' '] key <> "=\"" <> escape ['\"'] val <> "\""
coToken (BBContained t xs) = (<> "/]") . T.init . coToken $ BBOpen t xs
coToken (BBClose t) = "[/" <> escape [']'] t <> "]"
coToken (BBStr t) = escape ['['] t
coToken BBNewPar = "\n\n"
escape :: [Char] -> Text -> Text
-- ^ Inverse of `escapedText`
escape xs = endos [ T.replace c' ("\\" <> c') . T.replace ("\\" <> c') ("\\\\" <> c') | c <- xs, let c' = T.singleton c ] . escapeLast
where
endos = appEndo . mconcat . map Endo
escapeLast t
| T.null t = ""
| T.last t == '\\' = t <> "\\"
| otherwise = t
tokenize :: Text -> Either String [BBToken]
-- ^ Run 'many token' against input
tokenize = parseOnly (many token <* endOfInput)
spec :: Spec
spec = do
prop "prop_token" prop_token
zipWithM_ example [1..] examples
where
example n (s, ts) = let str = "Example " <> show n
in specify str (tokenize s == Right ts)
prop_token :: Text -> Property
-- ^ prop> (==) <$> (((mconcat . map coToken) <$> tokenize x) >>= tokenize) <*> tokenize x
--
-- Where 'x' is restricted such that `tokenize` succeeds
--
-- Without accounting for failure this is:
--
-- > (tokenize . mconcat . map coToken . tokenize x) == tokenize x
prop_token x = discardLeft $ (==) <$> (((mconcat . map coToken) <$> tokenize x) >>= tokenize) <*> tokenize x
where
discardLeft = either (const $ property Discard) property
examples :: [(Text, [BBToken])]
examples = [ ("[t]test[/t]"
, [BBOpen "t" [], BBStr "test", BBClose "t"])
, ("[t]te\\st[/t]"
, [BBOpen "t" [], BBStr "te\\st", BBClose "t"])
, ("[t]te\\[st[/t]"
, [BBOpen "t" [], BBStr "te[st", BBClose "t"])
, ("[t]test\\\\[/t]"
, [BBOpen "t" [], BBStr "test\\", BBClose "t"])
, ("[t]test\\[/t]"
, [BBOpen "t" [], BBStr "test[/t]"])
, ("[\\t]test[/t]"
, [BBOpen "\\t" [], BBStr "test", BBClose "t"])
, ("[t]test[/t\\]]"
, [BBOpen "t" [], BBStr "test", BBClose "t]"])
, ("[t attr]test[/t]"
, [BBOpen "t" [("attr", "")], BBStr "test", BBClose "t"])
, ("[t=attr]test[/t]"
, [BBOpen "t" [("", "attr")], BBStr "test", BBClose "t"])
, ("[t attr=val]test[/t]"
, [BBOpen "t" [("attr", "val")], BBStr "test", BBClose "t"])
, ("[t attr=\"val\"]test[/t]"
, [BBOpen "t" [("attr", "val")], BBStr "test", BBClose "t"])
, ("[t attr=\"va]l\"]test[/t]"
, [BBOpen "t" [("attr", "va]l")], BBStr "test", BBClose "t"])
, ("[t attr=\"va\\\"l\"]test[/t]"
, [BBOpen "t" [("attr", "va\"l")], BBStr "test", BBClose "t"])
, ("[t attr=\"val\" attr2=\"val2\" ]test[/t]"
, [BBOpen "t" [("attr", "val"), ("attr2", "val2")], BBStr "test", BBClose "t"])
, ("[br/]"
, [BBContained "br" []])
, ("[br attr/]"
, [BBContained "br" [("attr", "")]])
, ("[br=val/]"
, [BBContained "br" [("", "val")]])
, ("[br attr=val/]"
, [BBContained "br" [("attr", "val")]])
, ("[br attr=val val2/]"
, [BBContained "br" [("attr", "val"), ("val2", "")]])
, ("[foo\\/bar]"
, [BBOpen "foo/bar" []])
, ("foo\nbar"
, [BBStr "foo\nbar"])
, ("foo\n\nbar"
, [BBStr "foo", BBNewPar, BBStr "bar"])
, ("foo\n\n\r\n\r\nbar"
, [BBStr "foo", BBNewPar, BBStr "bar"])
]
|
